From: Alexander Shiryaev Date: Sat, 10 Nov 2012 18:58:33 +0000 (+0400) Subject: Добавлено дерево BlackBox на основе наработок Trurl-а X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=02a3486a4adb7964c73018e2702ae19e0811e06e;p=bbcp.git Добавлено дерево BlackBox на основе наработок Trurl-а --- diff --git a/Trurl-based/Cons/Mod/Compiler.odc b/Trurl-based/Cons/Mod/Compiler.odc new file mode 100644 index 0000000..35ade6f Binary files /dev/null and b/Trurl-based/Cons/Mod/Compiler.odc differ diff --git a/Trurl-based/Cons/Mod/Interp.txt b/Trurl-based/Cons/Mod/Interp.txt new file mode 100644 index 0000000..9dac7e9 --- /dev/null +++ b/Trurl-based/Cons/Mod/Interp.txt @@ -0,0 +1,128 @@ +MODULE ConsInterp; + + (* + A. V. Shiryaev, 2012.09 + *) + + IMPORT + Console, + Strings, Dialog, + DevCommanders, TextModels, + StdLog; + + VAR + textR: TextModels.Reader; + + PROCEDURE ShowStdLog; + VAR c: CHAR; + BEGIN + StdLog.text.Append(StdLog.buf); + + textR.SetPos(0); + textR.ReadChar(c); + WHILE ~textR.eot DO + IF c = 0DX THEN + Console.WriteLn + ELSE + Console.WriteChar(c) + END; + textR.ReadChar(c) + END; + StdLog.text.Delete(0, StdLog.text.Length()) + END ShowStdLog; + + PROCEDURE Call1 (IN s: ARRAY OF CHAR; i: INTEGER): BOOLEAN; + VAR j: INTEGER; + res: INTEGER; + par: DevCommanders.Par; + m: TextModels.Model; w: TextModels.Writer; + BEGIN + (* ASSERT 0X in s[ i:LEN(s) ) *) + j := i; + WHILE s[j] # 0X DO INC(j) END; + IF j > i THEN + m := TextModels.dir.New(); + w := m.NewWriter(NIL); + WHILE i < j DO + w.WriteChar(s[i]); + INC(i) + END; + NEW(par); par.text := m; par.beg := 0; par.end := m.Length() - 1; + DevCommanders.par := par + END; + Dialog.Call(s, " ", res); + DevCommanders.par := NIL; + ShowStdLog; + RETURN res = 0 + END Call1; + + PROCEDURE Call0 (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + res: BOOLEAN; + inStr: BOOLEAN; + BEGIN + (* ASSERT s is 0X terminated and not empty *) + i := 0; + WHILE (s[i] # 0X) & (s[i] # ' ') & (s[i] # '(') DO + INC(i) + END; + IF s[i] = 0X THEN + res := Call1(s, i) + ELSIF s[i] = ' ' THEN + s[i] := 0X; + res := Call1(s, i + 1) + ELSE (* s[i] = '(' *) + INC(i); + inStr := FALSE; + WHILE (s[i] # 0X) & ~(~inStr & (s[i] = ')')) DO + IF s[i] = "'" THEN inStr := ~inStr END; + INC(i) + END; + IF s[i] # 0X THEN + INC(i); + IF s[i] = 0X THEN + res := Call1(s, i) + ELSE + s[i] := 0X; + res := Call1(s, i + 1) + END + ELSE + res := FALSE + END + END; + RETURN res + END Call0; + + PROCEDURE Call (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + res: BOOLEAN; + BEGIN + i := 0; + WHILE (i < LEN(s)) & (s[i] # 0AX) & (s[i] # 0DX) & (s[i] # 0X) DO + INC(i) + END; + IF (i < LEN(s)) & (s[i] # 0X) THEN + IF (i > 0) & (s[0] # '#') THEN + s[i] := 0X; + res := Call0(s) + ELSE (* skip empty strings and comments *) + res := TRUE + END + ELSE (* end of input *) + res := FALSE + END; + RETURN res + END Call; + + PROCEDURE Run*; + VAR s: ARRAY 1024 OF CHAR; + BEGIN + Console.ReadLn(s); + WHILE Call(s) DO + Console.ReadLn(s) + END + END Run; + +BEGIN + textR := StdLog.text.NewReader(NIL) +END ConsInterp. diff --git a/Trurl-based/Cons/Mod/Log.txt b/Trurl-based/Cons/Mod/Log.txt new file mode 100644 index 0000000..87f4fd6 --- /dev/null +++ b/Trurl-based/Cons/Mod/Log.txt @@ -0,0 +1,193 @@ +MODULE ConsLog; + + (* + A. V. Shiryaev, 2012.10 + + Log.Hook implementation + based on StdLog + *) + + IMPORT + Log, Views, Dialog, + TextModels, TextMappers, + Console; + + TYPE + LogHook = POINTER TO RECORD (Log.Hook) END; + + VAR + logAlerts: BOOLEAN; + subOut: TextMappers.Formatter; + + buf: TextModels.Model; + textR: TextModels.Reader; + + (* Sub support *) + + PROCEDURE* Guard (o: ANYPTR): BOOLEAN; + BEGIN + RETURN o # NIL + END Guard; + + PROCEDURE* ClearBuf; + VAR subBuf: TextModels.Model; + BEGIN + subBuf := subOut.rider.Base(); subBuf.Delete(0, subBuf.Length()) + END ClearBuf; + + PROCEDURE* FlushBuf; + VAR c: CHAR; + BEGIN + IF buf.Length() > 0 THEN + textR.SetPos(0); + textR.ReadChar(c); + WHILE ~textR.eot DO + IF c = 0DX THEN + Console.WriteLn + ELSE + Console.WriteChar(c) + END; + textR.ReadChar(c) + END; + buf.Delete(0, buf.Length()) + 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()); + buf := subOut.rider.Base(); + textR := buf.NewReader(NIL); + NEW(h); + Log.SetHook(h); + END AttachSubLog; + + PROCEDURE DetachSubLog; + BEGIN + Log.SetHook(NIL) + END DetachSubLog; + +BEGIN + AttachSubLog +CLOSE + DetachSubLog; +END ConsLog. diff --git a/Trurl-based/Dev/Docu/ElfLinker.odc b/Trurl-based/Dev/Docu/ElfLinker.odc new file mode 100644 index 0000000..7ce87b4 Binary files /dev/null and b/Trurl-based/Dev/Docu/ElfLinker.odc differ diff --git a/Trurl-based/Dev/Mod/CPB.txt b/Trurl-based/Dev/Mod/CPB.txt new file mode 100644 index 0000000..56a840a --- /dev/null +++ b/Trurl-based/Dev/Mod/CPB.txt @@ -0,0 +1,2238 @@ +MODULE DevCPB; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPB.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPT, DevCPM; + + CONST + (* symbol values or ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; size = 37; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13; + + AssertTrap = 0; (* default trap number *) + + covarOut = FALSE; + + + VAR + typSize*: PROCEDURE(typ: DevCPT.Struct); + zero, one, two, dummy, quot: DevCPT.Const; + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node; + VAR node: DevCPT.Node; typ: DevCPT.Struct; + BEGIN + typ := obj.typ; + CASE obj.mode OF + Var: + node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0) + | VarPar: + node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar; + | Con: + node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst(); + node.conval^ := obj.conval^ (* string is not copied, only its ref *) + | Typ: + node := DevCPT.NewNode(Ntype) + | LProc..IProc, TProc: + node := DevCPT.NewNode(Nproc) + ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp + END ; + node.obj := obj; node.typ := typ; + RETURN node + END NewLeaf; + + PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := DevCPT.notyp; + node.left := x; node.right := y; x := node + END Construct; + + PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node); + BEGIN + IF x = NIL THEN x := y ELSE last.link := y END ; + WHILE y.link # NIL DO y := y.link END ; + last := y + END Link; + + PROCEDURE BoolToInt(b: BOOLEAN): INTEGER; + BEGIN + IF b THEN RETURN 1 ELSE RETURN 0 END + END BoolToInt; + + PROCEDURE IntToBool(i: INTEGER): BOOLEAN; + BEGIN + IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END + END IntToBool; + + PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x + END NewBoolConst; + + PROCEDURE OptIf*(VAR x: DevCPT.Node); (* x.link = NIL *) + VAR if, pred: DevCPT.Node; + BEGIN + if := x.left; + WHILE if.left.class = Nconst DO + IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN + ELSIF if.link = NIL THEN x := x.right; RETURN + ELSE if := if.link; x.left := if + END + END ; + pred := if; if := if.link; + WHILE if # NIL DO + IF if.left.class = Nconst THEN + IF IntToBool(if.left.conval.intval) THEN + pred.link := NIL; x.right := if.right; RETURN + ELSE if := if.link; pred.link := if + END + ELSE pred := if; if := if.link + END + END + END OptIf; + + PROCEDURE Nil*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x + END Nil; + + PROCEDURE EmptySet*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp; + x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x + END EmptySet; + + PROCEDURE MarkAsUsed (node: DevCPT.Node); + VAR c: BYTE; + BEGIN + c := node.class; + WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END; + IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END + END MarkAsUsed; + + + PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object); + VAR n: DevCPT.Name; o: DevCPT.Object; + BEGIN + n := "@@ "; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *) + obj.mode := Var; obj.typ := typ; + o := DevCPT.topScope.scope; + IF o = NIL THEN DevCPT.topScope.scope := obj + ELSE + WHILE o.link # NIL DO o := o.link END; + o.link := obj + END + END GetTempVar; + + + (* ---------- constant operations ---------- *) + + PROCEDURE Log (x: DevCPT.Node): INTEGER; + VAR val, exp: INTEGER; + BEGIN + exp := 0; + IF x.typ.form = Int64 THEN + RETURN -1 + ELSE + val := x.conval.intval; + IF val > 0 THEN + WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END + END; + IF val # 1 THEN exp := -1 END + END; + RETURN exp + END Log; + + PROCEDURE Floor (x: REAL): REAL; + VAR y: REAL; + BEGIN + IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x + ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN + y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0); + RETURN SHORT(ENTIER(x - y)) + y + ELSE RETURN SHORT(ENTIER(x)) + END + END Floor; + + PROCEDURE SetToInt (s: SET): INTEGER; + VAR x, i: INTEGER; + BEGIN + i := 31; x := 0; + IF 31 IN s THEN x := -1 END; + WHILE i > 0 DO + x := x * 2; DEC(i); + IF i IN s THEN INC(x) END + END; + RETURN x + END SetToInt; + + PROCEDURE IntToSet (x: INTEGER): SET; + VAR i: INTEGER; s: SET; + BEGIN + i := 0; s := {}; + WHILE i < 32 DO + IF ODD(x) THEN INCL(s, i) END; + x := x DIV 2; INC(i) + END; + RETURN s + END IntToSet; + + PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct); + CONST MAXL = 9223372036854775808.0; (* 2^63 *) + BEGIN + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF form IN intSet THEN + IF x.realval = 0 THEN typ := DevCPT.int32typ + ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ + ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ + END + ELSIF form IN realSet THEN (* SR *) + typ := DevCPT.real64typ + ELSIF form IN charSet THEN + IF x.intval <= 255 THEN typ := DevCPT.char8typ + ELSE typ := DevCPT.char16typ + END + ELSE typ := DevCPT.undftyp + END + END GetConstType; + + PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT); + VAR type: DevCPT.Struct; + BEGIN + GetConstType(x, form, errno, type); + IF ~DevCPT.Includes(form, type.form) + & ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + & ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + & ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN + err(errno); x.intval := 1; x.realval := 0 + END +(* + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval)) + OR (form = Int32) & (x.realval # 0) + OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535)) + OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255)) + OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN + err(errno); x.intval := 1; x.realval := 0 + END +*) + END CheckConstType; + + PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER); + VAR sr: SHORTREAL; + BEGIN + IF from = Set THEN + x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {}; + ELSIF from IN intSet + charSet THEN + IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval) + ELSIF to IN intSet THEN CheckConstType(x, to, 203) + ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc + ELSE (*to IN charSet*) CheckConstType(x, to, 220) + END + ELSIF from IN realSet THEN + IF to IN realSet THEN CheckConstType(x, to, 203); + IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *) + ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203) + END + END + END ConvConst; + + PROCEDURE Prepare (x: DevCPT.Const); + VAR r: REAL; + BEGIN + x.realval := x.realval + x.intval DIV 32768 * 32768; + x.intval := x.intval MOD 32768; + r := Floor(x.realval / 4096) * 4096; + x.intval := x.intval + SHORT(ENTIER(x.realval - r)); + x.realval := r + (* ABS(x.intval) < 2^15 & ABS(x.realval) MOD 2^12 = 0 *) + END Prepare; + + PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval + y.intval; z.realval := x.realval + y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212) + ELSE z.realval := x.realval + y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 206, type) + END AddConst; + + PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *) + BEGIN + IF type.form IN intSet THEN Prepare(y); z.intval := -y.intval; z.realval := -y.realval + ELSIF type.form IN realSet THEN z.realval := -y.realval + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END NegateConst; + + PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval - y.intval; z.realval := x.realval - y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = y.realval) THEN err(212) + ELSE z.realval := x.realval - y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END SubConst; + + PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval; + z.intval := x.intval * y.intval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212) + ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212) + ELSE z.realval := x.realval * y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END MulConst; + + PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *) + BEGIN + IF type.form IN realSet THEN + IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212) + ELSIF (ABS(x.realval) = DevCPM.InfReal) & (ABS(y.realval) = DevCPM.InfReal) THEN err(212) + ELSE z.realval := x.realval / y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END DivConst; + + PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct); + (* x := x DIV y | x MOD y *) + BEGIN + IF type.form IN intSet THEN + IF y.realval + y.intval # 0 THEN + Prepare(x); Prepare(y); + quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval)); + quot.intval := 0; Prepare(quot); + x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval; + x.intval := x.intval - quot.intval * y.intval; + IF y.realval + y.intval > 0 THEN + WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + ELSE + WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + END; + IF div THEN x.realval := quot.realval; x.intval := quot.intval END; + GetConstType(x, type.form, 204, type) + ELSE err(205) + END + ELSE HALT(100) + END + END DivModConst; + + PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0 + | Real32, Real64: res := x.realval = y.realval + | Set: res := x.setval = y.setval + | String8, String16, Comp (* guid *): res := x.ext^ = y.ext^ + | NilTyp, Pointer, ProcTyp: res := x.intval = y.intval + END; + RETURN res + END EqualConst; + + PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Byte, Char8..Int32, Char16: res := x.intval < y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0 + | Real32, Real64: res := x.realval < y.realval + | String8, String16: res := x.ext^ < y.ext^ + | Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108) + END; + RETURN res + END LessConst; + + PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0 OR x = (-0.0) *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Int8..Int32: res := x.intval < 0 + | Int64: Prepare(x); res := x.realval + x.intval < 0 + | Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.) + END; + RETURN res + END IsNegConst; + + + PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x + END NewIntConst; + + PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x + END NewLargeIntConst; + + PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc; + IF typ = NIL THEN typ := DevCPT.real64typ END; + x.typ := typ; + RETURN x + END NewRealConst; + + PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node; + VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + IF lstr # NIL THEN + x.typ := DevCPT.string16typ; + NEW(ext, 3 * len); i := 0; j := 0; + REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0; + x.conval.ext := ext + ELSE + x.typ := DevCPT.string8typ; x.conval.ext := str + END; + x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len; + RETURN x + END NewString; + + PROCEDURE CharToString8(n: DevCPT.Node); + VAR ch: SHORTCHAR; + BEGIN + n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2); + IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ; + n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString8; + + PROCEDURE CharToString16 (n: DevCPT.Node); + VAR ch, ch1: SHORTCHAR; i: INTEGER; + BEGIN + n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4); + IF n.conval.intval = 0 THEN + n.conval.ext[0] := 0X; n.conval.intval2 := 1 + ELSE + i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i); + n.conval.ext[i] := 0X; n.conval.intval2 := 2 + END; + n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString16; + + PROCEDURE String8ToString16 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string16typ; ext := n.conval.ext; + NEW(new, 2 * n.conval.intval2); i := 0; j := 0; + REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String8ToString16; + + PROCEDURE String16ToString8 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string8typ; ext := n.conval.ext; + NEW(new, n.conval.intval2); i := 0; j := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String16ToString8; + + PROCEDURE StringToGuid (VAR n: DevCPT.Node); + BEGIN + ASSERT((n.class = Nconst) & (n.typ.form = String8)); + IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END; + n.typ := DevCPT.guidtyp + END StringToGuid; + + PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT); + VAR ntyp: DevCPT.Struct; + BEGIN + ntyp := n.typ; + IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n) + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN + IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *) + ELSE err(e) + END + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN + IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n) + ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN + (* ok *) + ELSE err(e) + END + ELSE err(e) + END + END CheckString; + + + PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := typ; + node.left := x; node.right := y; x := node + END BindNodes; + + PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst)) + OR (x.typ.form IN {String8, String16}) + END NotVar; + + + PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL; + BEGIN f := x.typ.form; g := typ.form; + IF x.class = Nconst THEN + IF g = String8 THEN + IF f = String16 THEN String16ToString8(x) + ELSIF f IN charSet THEN CharToString8(x) + ELSE typ := DevCPT.undftyp + END + ELSIF g = String16 THEN + IF f = String8 THEN String8ToString16(x) + ELSIF f IN charSet THEN CharToString16(x) + ELSE typ := DevCPT.undftyp + END + ELSE ConvConst(x.conval, f, g) + END; + x.obj := NIL + ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g)) + THEN + (* don't create new node *) + IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END + ELSE + IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *) + Convert(x.left, typ); Convert(x.right, typ) + ELSE + node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node; + END + END; + x.typ := typ + END Convert; + + PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *) + VAR f, g: INTEGER; new: DevCPT.Struct; + BEGIN + f := left.typ.form; g := right.typ.form; new := left.typ; + IF f IN intSet + realSet THEN + IF g IN intSet + realSet THEN + IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst) + (* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(right.conval.realval) = DevCPM.InfReal)) *) + OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst) + (* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN + new := DevCPT.real32typ (* SR *) + ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ + ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *) + ELSIF op = slash THEN new := DevCPT.real64typ + ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ + ELSE new := DevCPT.int32typ + END + ELSE err(100) + END + ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN + IF f = String8 THEN StringToGuid(left) END; + IF g = String8 THEN StringToGuid(right) END; + IF left.typ # right.typ THEN err(100) END; + f := Comp + ELSIF f IN charSet + {String8, String16} THEN + IF g IN charSet + {String8, String16} THEN + IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN + new := DevCPT.string16typ + ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ + ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ + ELSIF op = plus THEN + IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ + ELSE new := DevCPT.string8typ + END + END; + IF (new.form IN {String8, String16}) + & ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst)) + THEN + err(100) + END + ELSE err(100) + END + ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN + IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp) + & ~((f = Pointer) & (g = Pointer) + & (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END + ELSIF f # g THEN err(100) + END; + IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN + IF g # new.form THEN Convert(right, new) END; + IF f # new.form THEN Convert(left, new) END + END + END Promote; + + PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *) + VAR ft, at: DevCPT.Struct; + BEGIN + WHILE fp # NIL DO + IF ap # NIL THEN + ft := fp.typ; at := ap.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *) + IF ~DevCPT.EqualType(ft, at) + OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis) + OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ; + ap := ap.link + ELSE err(116) + END; + fp := fp.link + END; + IF ap # NIL THEN err(116) END + END CheckParameters; + + PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node); + VAR ityp, ntyp: DevCPT.Struct; + BEGIN + ntyp := newPar.typ.BaseTyp; + IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN + IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev) + THEN (* ok *) + ELSE err(168) + END + ELSIF ntyp.extlev = 0 THEN (* ok *) + ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN + IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END + ELSE err(168) + END + END CheckNewParamPair; + + + PROCEDURE DeRef*(VAR x: DevCPT.Node); + VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF typ.form = Pointer THEN + btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN + btyp.pbused := TRUE + END ; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 0 + ELSE err(84) + END + END DeRef; + + PROCEDURE StrDeref*(VAR x: DevCPT.Node); + VAR typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ + ELSE btyp := DevCPT.string16typ + END; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 1 + ELSE err(90) + END + END StrDeref; + + PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; + BEGIN + f := y.typ.form; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79) + ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ; + IF f = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.typ.comp = Array THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END + ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END + ELSE err(82); typ := DevCPT.undftyp + END ; + BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly + END Index; + + PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object); + BEGIN (*x.typ.comp = Record*) + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ; + IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN + BindNodes(Nfield, y.typ, x, NIL); x.obj := y; + x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0)) + ELSE err(83); x.typ := DevCPT.undftyp + END + END Field; + + PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN); + + PROCEDURE GTT(t0, t1: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN + IF ~guard THEN x := NewBoolConst(TRUE) END + ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint) + OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN + IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly + ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node + END + ELSE err(85) + END + END GTT; + + BEGIN + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112) + ELSIF x.typ.form = Pointer THEN + IF x.typ = DevCPT.sysptrtyp THEN + IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF x.typ.BaseTyp.comp # Record THEN err(85) + ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN + GTT(x.typ, obj.typ) + ELSE err(87) + END ; + IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END + END TypTest; + + PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; k: INTEGER; + BEGIN f := x.typ.form; + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (f IN intSet) & (y.typ.form = Set) THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202) + ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE err(92) + END ; + x.typ := DevCPT.booltyp + END In; + + PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ; + node.left := z; RETURN node + END NewOp; + + BEGIN z := x; + IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *) + ELSE + typ := z.typ; f := typ.form; + CASE op OF + | not: + IF f = Bool THEN + IF z.class = Nconst THEN + z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + | plus: + IF ~(f IN intSet + realSet) THEN err(96) END + | minus: + IF f IN intSet + realSet + {Set} THEN + IF z.class = Nconst THEN + IF f = Set THEN z.conval.setval := -z.conval.setval + ELSE NegateConst(z.conval, z.conval, z.typ) + END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(97) + END + | abs: + IF f IN intSet + realSet THEN + IF z.class = Nconst THEN + IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(111) + END + | cap: + IF f IN charSet THEN + IF z.class = Nconst THEN + IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END; + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z.typ := DevCPT.char8typ + END + | odd: + IF f IN intSet THEN + IF z.class = Nconst THEN + DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *) + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z.typ := DevCPT.booltyp + | adr: (*ADR*) + IF z.class = Nproc THEN + IF z.obj.mnolev > 0 THEN err(73) + ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc + END; + z := NewOp(op, typ, z) + ELSIF z.class = Ntype THEN + IF z.obj.typ.untagged THEN err(111) END; + z := NewOp(op, typ, z) + ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN + z := NewOp(op, typ, z) + ELSE err(127) + END ; + z.typ := DevCPT.int32typ + | typfn, size: (*TYP, SIZE*) + z := NewOp(op, typ, z); + z.typ := DevCPT.int32typ + | cc: (*SYSTEM.CC*) + IF (f IN intSet) & (z.class = Nconst) THEN + IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN + z := NewOp(op, typ, z) + ELSE err(219) + END + ELSE err(69) + END; + z.typ := DevCPT.booltyp + END + END; + x := z + END MOp; + + PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node); + VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct; + BEGIN + f := x.typ.form; + IF f = y.typ.form THEN + xval := x.conval; yval := y.conval; + CASE op OF + | times: + IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval * yval.setval + ELSIF f # Undef THEN err(101) + END + | slash: + IF f IN realSet THEN DivConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval / yval.setval + ELSIF f # Undef THEN err(102) + END + | div: + IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ) + ELSIF f # Undef THEN err(103) + END + | mod: + IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ) + ELSIF f # Undef THEN err(104) + END + | and: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval)) + ELSE err(94) + END + | plus: + IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval + yval.setval + ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN + NEW(ext, LEN(xval.ext^) + LEN(yval.ext^)); + i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END; + j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END; + ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1) + ELSIF f # Undef THEN err(105) + END + | minus: + IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval - yval.setval + ELSIF f # Undef THEN err(106) + END + | min: + IF f IN intSet + realSet THEN + IF LessConst(yval, xval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | max: + IF f IN intSet + realSet THEN + IF LessConst(xval, yval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | or: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval)) + ELSE err(95) + END + | eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + | leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + END + ELSE err(100) + END; + x.obj := NIL + END ConstOp; + + PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ; + node.left := x; node.right := y; x := node + END NewOp; + + BEGIN z := x; + IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSE + Promote(z, y, op); + IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y) + ELSE + typ := z.typ; f := typ.form; g := y.typ.form; + CASE op OF + | times: + do := TRUE; + IF f IN intSet THEN + IF z.class = Nconst THEN + IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y + ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE + ELSE val := Log(z); + IF val >= 0 THEN + t := y; y := z; z := t; + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + ELSIF y.class = Nconst THEN + IF EqualConst(y.conval, one, f) THEN do := FALSE + ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + END + ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | slash: + IF f IN realSet THEN (* OK *) + ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y) + | div: + do := TRUE; + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSIF EqualConst(y.conval, one, f) THEN do := FALSE + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | mod: + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSE val := Log(y); + IF val >= 0 THEN + op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y); + | and: + IF f = Bool THEN + IF z.class = Nconst THEN + IF IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp + END + | plus: + IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END; + do := TRUE; + IF f IN intSet THEN + IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END + ELSIF f IN {String8, String16} THEN + IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END; + IF do THEN + IF z.class = Ndop THEN + t := z; WHILE t.right.class = Ndop DO t := t.right END; + IF (t.right.class = Nconst) & (y.class = Nconst) THEN + ConstOp(op, t.right, y); do := FALSE + ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE + ELSE + NewOp(op, typ, t.right, y); do := FALSE + END + ELSE + IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE + END + END + END + END ; + IF do THEN NewOp(op, typ, z, y) END; + | minus: + IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END; + IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y) + END; + | min, max: + IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END; + NewOp(op, typ, z, y); + | or: + IF f = Bool THEN + IF z.class = Nconst THEN + IF ~IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp + END + | eql, neq, lss, leq, gtr, geq: + IF f IN {String8, String16} THEN + IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN + z := z.left; y := y.left (* remove LONG on both sides *) + ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *) + y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0 + ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *) + z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0 + END; + typ := DevCPT.booltyp + ELSIF (f IN {Undef, Char8..Real64, Char16, Int64}) + OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN + typ := DevCPT.booltyp + ELSE err(107); typ := DevCPT.undftyp + END; + NewOp(op, typ, z, y) + END + END + END; + x := z + END Op; + + PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR k, l: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END + END ; + IF y.class = Nconst THEN + l := y.conval.intval; + IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END + END ; + IF (x.class = Nconst) & (y.class = Nconst) THEN + IF k <= l THEN + x.conval.setval := {k..l} + ELSE err(201); x.conval.setval := {l..k} + END ; + x.obj := NIL + ELSE BindNodes(Nupto, DevCPT.settyp, x, y) + END + ELSE err(93) + END ; + x.typ := DevCPT.settyp + END SetRange; + + PROCEDURE SetElem*(VAR x: DevCPT.Node); + VAR k: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END; + IF x.typ.form IN intSet THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k} + ELSE err(202) + END ; + x.obj := NIL + ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit + END ; + ELSE err(93) + END; + x.typ := DevCPT.settyp + END SetElem; + + PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node); + (* x := y, checks assignment compatibility *) + VAR f, g: SHORTINT; y, b: DevCPT.Struct; + BEGIN + y := ynode.typ; f := x.form; g := y.form; + IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + CASE f OF + | Undef, String8, String16, Byte: + | Bool, Set: + IF g # f THEN err(113) END + | Int8, Int16, Int32, Int64, Real32, Real64: (* SR *) + IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN + IF ynode.class = Nconst THEN Convert(ynode, x) + ELSIF ~DevCPT.Includes(f, g) THEN err(113) + END + ELSE err(113) + END +(* + IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN + err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END +*) + | Char8, Char16: + IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END + | Pointer: + b := x.BaseTyp; + IF DevCPT.Extends(y, x) + OR (g = NilTyp) + OR (g = Pointer) + & ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp)) + THEN (* ok *) + ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *) + IF ynode.class = Nconst THEN CheckString(ynode, b, 113) + ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113) + END + ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *) + IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113) + ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113) + END + ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8})) + THEN + IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END + ELSE err(113) + END + | ProcTyp: + IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *) + ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN + IF ynode.obj.mode = LProc THEN + IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END + END; + IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN + IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE) + ELSE err(117) + END + ELSE err(113) + END + ELSE err(113) + END + | NoTyp, NilTyp: err(113) + | Comp: + x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x.comp = Record THEN + IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END + ELSIF g IN {Char8, Char16, String8, String16} THEN + IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ) + ELSE CheckString(ynode, x, 113); + END; + IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN + err(114) + END + ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *) + ELSE err(113) + END + END + END CheckAssign; + + PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *) + BEGIN + ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16})); + IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *) + Index(x, NewIntConst(0)); + str.typ := x.typ; str.conval.intval := 0; + END; + BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign + END AssignString; + + PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN); + BEGIN + IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ; + IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *) + IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END + END CheckLeaf; + + PROCEDURE CheckOldType (x: DevCPT.Node); + BEGIN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN + err(198) + END + END CheckOldType; + + PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *) + VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node; + BEGIN x := par0; f := x.typ.form; + CASE fctno OF + haltfn: (*HALT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(218) + END + ELSIF (DevCPM.java IN DevCPM.options) + & ((x.class = Ntype) OR (x.class = Nvar)) + & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(69) + END ; + x.typ := DevCPT.notyp + | newfn: (*NEW*) + typ := DevCPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = Pointer THEN + IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x.readonly THEN err(76) + ELSIF (x.typ.BaseTyp.attribute = absAttr) + OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + f := x.typ.BaseTyp.comp; + IF f IN {Record, DynArr, Array} THEN + IF f = DynArr THEN typ := x.typ.BaseTyp END ; + BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn + ELSE err(111) + END + ELSE err(111) + END ; + x.typ := typ + | absfn: (*ABS*) + MOp(abs, x) + | capfn: (*CAP*) + MOp(cap, x) + | ordfn: (*ORD*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Set THEN Convert(x, DevCPT.int32typ) + ELSE err(111) + END + | bitsfn: (*BITS*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp) + ELSE err(111) + END + | entierfn: (*ENTIER*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | lentierfcn: (* LENTIER *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | oddfn: (*ODD*) + MOp(odd, x) + | minfn: (*MIN*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(FALSE) + | Char8: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Int8: x := NewIntConst(-128) + | Int16: x := NewIntConst(-32768) + | Int32: x := NewIntConst(-2147483648) + | Int64: x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *) + | Set: x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | maxfn: (*MAX*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(TRUE) + | Char8: x := NewIntConst(0FFH); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ + | Int8: x := NewIntConst(127) + | Int16: x := NewIntConst(32767) + | Int32: x := NewIntConst(2147483647) + | Int64: x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *) + | Set: x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | chrfn: (*CHR*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | lchrfn: (* LCHR *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | shortfn: (*SHORT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int16 THEN Convert(x, DevCPT.int8typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ) + ELSIF f = String16 THEN Convert(x, DevCPT.string8typ) + ELSE err(111) + END + END + | longfn: (*LONG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ) + ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ) + ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ) + ELSIF f = String8 THEN Convert(x, DevCPT.string16typ) + ELSE err(111) + END + END + | incfn, decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF ~(f IN intSet) THEN err(111) + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | inclfn, exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | lenfn: (*LEN*) + IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *) + (* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.class = Nconst THEN + IF x.typ.form = Char8 THEN CharToString8(x) + ELSIF x.typ.form = Char16 THEN CharToString16(x) + END + END; + IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END + END + | copyfn: (*COPY*) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END + ELSE err(111); x.typ := DevCPT.int32typ + END + | adrfn: (*ADR*) + IF x.class = Ntype THEN CheckOldType(x) END; + CheckLeaf(x, FALSE); MOp(adr, x) + | typfn: (*TYP*) + CheckLeaf(x, FALSE); + IF x.class = Ntype THEN + CheckOldType(x); + IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(adr, x) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(typfn, x) + END + | sizefn: (*SIZE*) + IF x.class # Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN + CheckOldType(x); x.typ.pvused := TRUE; + IF typSize # NIL THEN + typSize(x.typ); x := NewIntConst(x.typ.size) + ELSE + MOp(size, x) + END + ELSE err(111); x := NewIntConst(1) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ) + ELSIF f # Int32 THEN err(111) + END + | ccfn: (*SYSTEM.CC*) + MOp(cc, x) + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111) + END + | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END + | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN intSet) & (x.class = Nconst) THEN + IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220) + END + ELSE err(69) + END + | valfn: (*SYSTEM.VAL*) + IF x.class # Ntype THEN err(110) + ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111) + ELSE CheckOldType(x) + END + | assertfn: (*ASSERT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(not, x) + END + | validfn: (* VALID *) + IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN + MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil()) + ELSE err(111) + END; + x.typ := DevCPT.booltyp + | iidfn: (* COM.IID *) + IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x) + ELSE + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN + IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END + ELSE err(111) + END; + x.class := Nconst; x.typ := DevCPT.guidtyp + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f # Pointer THEN err(111) + END + END ; + par0 := x + END StPar0; + + PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE); + (* x: second parameter of standard proc *) + VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node; + + PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.subcl := subcl; + node.left := left; node.right := right; RETURN node + END NewOp; + + BEGIN p := par0; f := x.typ.form; + CASE fctno OF + incfn, decfn: (*INC DEC*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp + ELSE + IF f # p.typ.form THEN + IF f IN intSet THEN Convert(x, p.typ) + ELSE err(111) + END + END ; + p := NewOp(Nassign, fctno, p, x); + p.typ := DevCPT.notyp + END + | inclfn, exclfn: (*INCL, EXCL*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202) + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | lenfn: (*LEN*) + IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69) + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + L := SHORT(x.conval.intval); typ := p.typ; + WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132) + ELSE x.obj := NIL; + IF typ.comp = DynArr THEN + WHILE p.class = Nindex DO + p := p.left; INC(x.conval.intval) (* possible side effect ignored *) + END; + p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ + ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ + END + END + END + | copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF x.readonly THEN err(76) + ELSE + CheckString(p, x.typ, 111); t := x; x := p; p := t; + IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x) + ELSE p := NewOp(Nassign, copyfn, p, x) + END + END ; + p.typ := DevCPT.notyp; MarkAsUsed(x) + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208) + ELSIF (p.class = Nconst) & (x.class = Nconst) THEN + n := x.conval.intval; + IF n > 0 THEN + WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END + ELSE + WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END + END; + p.obj := NIL + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ + END + ELSE err(111) + END + | minfn: (*MIN*) + IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END + | maxfn: (*MAX*) + IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END + | newfn: (*NEW(p, x...)*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp = DynArr THEN + IF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) + & (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END + ELSE err(111) + END ; + p.right := x; p.typ := p.typ.BaseTyp + ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN + typ := p.left.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF typ.sysflag = interface THEN + typ := x.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF (f = Pointer) & (typ.sysflag = interface) THEN + p.right := x + ELSE err(169) + END + ELSE err(64) + END + ELSE err(111) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END; + p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp + ELSE err(111) + END + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet) THEN err(111) + ELSE + IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; + p.typ := p.left.typ + END + | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN + IF (fctno = getfn) OR (fctno = getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | bitfn: (*SYSTEM.BIT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + p := NewOp(Ndop, bit, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.booltyp + | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *) + ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN + typ := x.typ; + WHILE typ.comp = DynArr DO typ := typ.BaseTyp END; + tp1 := p.typ; + WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END; + IF typ.size # tp1.size THEN err(115) END + ELSE err(115) + END + ELSIF p.typ.comp = DynArr THEN err(115) + ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN + i := 0; n := 0; + WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END; + x := NewIntConst(n) + ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111) + END ; + IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *) + ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet)) + OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN + t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t + ELSE x.readonly := FALSE + END ; + x.typ := p.typ; p := x + | movefn: (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END ; + p.link := x + | assertfn: (*ASSERT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(218) + END + ELSIF + (DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(69) + END; + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp + END; + p.link := x + ELSE err(64) + END ; + par0 := p + END StPar1; + + PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT); + (* x: n+1-th param of standard proc *) + VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct; + BEGIN p := par0; f := x.typ.form; + IF fctno = newfn THEN (*NEW(p, ..., x...*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp # DynArr THEN err(64) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END; + node := p.right; WHILE node.link # NIL DO node := node.link END; + node.link := x; p.typ := p.typ.BaseTyp + ELSE err(111) + END + ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p; + node.left := p.link; p.link := x; p := node + ELSE err(111) + END ; + p.typ := DevCPT.notyp + ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN + IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END; + IF x.readonly THEN err(76) END; + CheckNewParamPair(x, p.link); + MarkAsUsed(x); + node := DevCPT.NewNode(Ndop); node.subcl := queryfn; + node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node + ELSE err(111) + END; + p.typ := DevCPT.booltyp + ELSE err(64) + END ; + par0 := p + END StParN; + + PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT); + VAR dim: SHORTINT; x, p: DevCPT.Node; + BEGIN p := par0; + IF fctno <= ashfn THEN + IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN + IF p.typ.comp = DynArr THEN err(65) END ; + p.typ := DevCPT.notyp + ELSIF (fctno = minfn) OR (fctno = maxfn) THEN + IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END; + p.hint := 0 + ELSIF fctno <= sizefn THEN (* 1 param *) + IF parno < 1 THEN err(65) END + ELSE (* more than 1 param *) + IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ + ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) + IF p.typ.form IN {String8, String16} THEN + IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1) + ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *) + StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ + ELSE + WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END; + IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END; + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len + END + ELSIF p.typ.comp = DynArr THEN dim := 0; + WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len + ELSE + p := NewIntConst(p.typ.n) + END + ELSIF parno < 2 THEN err(65) + END + END + ELSIF fctno = assertfn THEN + IF parno = 1 THEN x := NIL; + BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap)); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + ELSIF parno < 1 THEN err(65) + END + ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN + IF parno < 1 THEN err(65) END + ELSIF fctno < validfn THEN (*SYSTEM*) + IF (parno < 1) OR + (fctno > ccfn) & (parno < 2) OR + (fctno = movefn) & (parno < 3) THEN err(65) + END + ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN + IF parno < 2 THEN err(65) END + ELSE (* COM *) + IF fctno = queryfn THEN + IF parno < 3 THEN err(65) END + ELSE + IF parno < 1 THEN err(65) END + END + END ; + par0 := p + END StFct; + + PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN); + (* check array compatibility *) + VAR atyp: DevCPT.Struct; + BEGIN (* ftyp.comp = DynArr *) + atyp := ap.typ; + IF atyp.form IN {Char8, Char16, String8, String16} THEN + IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ) + ELSE CheckString(ap, ftyp, 67) + END + ELSE + WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END; + IF ftyp.comp = DynArr THEN err(67) + ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *) + ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66) + END + END + END DynArrParCheck; + + PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object); + BEGIN + IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN + fpar := x.obj.link; + IF x.obj.mode = TProc THEN + IF fpar.typ.form = Pointer THEN + IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END + END; + fpar := fpar.link + END + ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN + fpar := x.typ.link + ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp + END + END PrepCall; + + PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *) + VAR at, ft: DevCPT.Struct; + BEGIN + at := ap.typ; ft := fp.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ft.form # Undef THEN + IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END; + IF fp.mode = VarPar THEN + IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *) + ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *) + ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN + (* ok *) + ELSE + IF fp.vis = inPar THEN + IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN + StringToGuid(ap); at := ap.typ +(* + ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp)) + & ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *) + ELSIF NotVar(ap) THEN err(122) +*) + END; + IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END + ELSE + IF NotVar(ap) THEN err(122) + ELSIF ap.readonly THEN err(76) + ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN + err(167) + ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE) + END + END; + IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar) + ELSIF ODD(fp.sysflag DIV newBit) THEN + IF ~DevCPT.Extends(at, ft) THEN err(123) END + ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *) + ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *) + ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *) + ELSIF fp.vis = inPar THEN CheckAssign(ft, ap) + ELSIF ~DevCPT.EqualType(ft, at) THEN err(123) + END + END + ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE) + ELSE CheckAssign(ft, ap) + END + END + END Param; + + PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN); + VAR scope: DevCPT.Object; + BEGIN + scope := DevCPT.topScope; + WHILE dlev > 0 DO DEC(dlev); + INCL(scope.link.conval.setval, slNeeded); + scope := scope.left + END; + IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *) + END StaticLink; + + PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object); + VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE; + BEGIN + IF x.class = Nproc THEN typ := x.typ; + lev := x.obj.mnolev; + IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *) + IF x.obj.mode = IProc THEN err(121) END + ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ; + x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link + ELSE typ := x.typ.BaseTyp + END ; + BindNodes(Ncall, typ, x, apar); x.obj := fp + END Call; + + PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object); + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc; + x.left := procdec; x.right := stat; procdec := x + END Enter; + + PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object); + VAR node: DevCPT.Node; + BEGIN + IF proc = NIL THEN (* return from module *) + IF x # NIL THEN err(124) END + ELSE + IF x # NIL THEN CheckAssign(proc.typ, x) + ELSIF proc.typ # DevCPT.notyp THEN err(124) + END + END ; + node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node + END Return; + + PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR z: DevCPT.Node; + BEGIN + IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ; + CheckAssign(x.typ, y); + IF x.readonly THEN err(76) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y) + ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign + END + END Assign; + + PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ninittd); node.typ := typ; + node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos; + IF inittd = NIL THEN inittd := node ELSE last.link := node END ; + last := node + END Inittd; + + (* handling of temporary variables for string operations *) + + PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN; + BEGIN + IF right.class = Nconst THEN + RETURN FALSE + ELSIF (right.class = Ndop) & (right.subcl = plus) THEN + RETURN Overlap(left, right.left) OR Overlap(left, right.right) + ELSE + WHILE right.class = Nmop DO right := right.left END; + IF right.class = Nderef THEN right := right.left END; + IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END; + LOOP + IF left.class = Nvarpar THEN + WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO + right := right.left + END; + RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev) + ELSIF right.class = Nvarpar THEN + WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END; + RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev) + ELSIF (left.class = Nvar) & (right.class = Nvar) THEN + RETURN left.obj = right.obj + ELSIF (left.class = Nderef) & (right.class = Nderef) THEN + RETURN TRUE + ELSIF (left.class = Nindex) & (right.class = Nindex) THEN + IF (left.right.class = Nconst) & (right.right.class = Nconst) + & (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END; + left := left.left; right := right.left + ELSIF (left.class = Nfield) & (right.class = Nfield) THEN + IF left.obj # right.obj THEN RETURN FALSE END; + left := left.left; right := right.left; + WHILE left.class = Nguard DO left := left.left END; + WHILE right.class = Nguard DO right := right.left END + ELSE + RETURN FALSE + END + END + END + END Overlap; + + PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER); + VAR x: INTEGER; + BEGIN + IF n.class = Nconst THEN + length := n.conval.intval2 - 1 + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetStaticLength(n.left, length); GetStaticLength(n.right, x); + IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := n.typ.n - 1 + ELSIF n.typ.comp = DynArr THEN + length := -1 + ELSE (* error case *) + length := 4 + END + END + END GetStaticLength; + + PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node); + VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object; + BEGIN + IF n.class = Nconst THEN + length := NewIntConst(n.conval.intval2 - 1) + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x); + IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x) + ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus + END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := NewIntConst(n.typ.n - 1) + ELSIF n.typ.comp = DynArr THEN + d := 0; + WHILE n.class = Nindex DO n := n.left; INC(d) END; + ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar)); + IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN + GetTempVar("@tmp", n.left.typ, obj); + x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x); + n.left := NewLeaf(obj); (* tree is manipulated here *) + n := NewLeaf(obj); DeRef(n) + END; + IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN + StrDeref(n); + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus + ELSE + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + END; + length := n + ELSE (* error case *) + length := NewIntConst(4) + END + END + END GetMaxLength; + + PROCEDURE CheckBuffering* ( + VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node + ); + VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER; + BEGIN + IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) + & ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right)) + OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL) + OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN + IF (par # NIL) & (par.typ.comp = Array) THEN + len := par.typ.n - 1 + ELSE + IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END; + GetStaticLength(n, xlen); + IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END + END; + IF len # -1 THEN + typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp; + GetTempVar("@str", typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + ELSE + IF left # NIL THEN GetMaxLength(left, stat, last, length) + ELSE GetMaxLength(n, stat, last, length) + END; + typ := DevCPT.NewStr(Pointer, Basic); + typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp; + GetTempVar("@ptr", typ, obj); + x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x); + x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj); DeRef(n) + END; + StrDeref(n) + ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL) + & ((par # NIL) OR (n.class = Ncall)) + & ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN + GetTempVar("@cip", DevCPT.punktyp, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckBuffering; + + PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node); + VAR x: DevCPT.Node; obj: DevCPT.Object; + BEGIN + IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN + GetTempVar("@ptr", n.typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckVarParBuffering; + + + (* case optimization *) + + PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node); + VAR a: INTEGER; + BEGIN + IF n.left # NIL THEN + a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head); + IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END + ELSIF n.conval.intval < min THEN + min := n.conval.intval + END; + IF n.right # NIL THEN + a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head); + IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END + ELSIF n.conval.intval2 > max THEN + max := n.conval.intval2 + END; + INC(num); + IF n.conval.intval < n.conval.intval2 THEN + INC(num); + IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END + END + END Evaluate; + + PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node); + VAR n: DevCPT.Node; + BEGIN + IF root # head THEN + IF head.conval.intval2 < root.conval.intval THEN + Rebuild(root.left, head); + root.left := head.right; head.right := root; root := head + ELSE + Rebuild(root.right, head); + root.right := head.left; head.left := root; root := head + END + END + END Rebuild; + + PROCEDURE OptimizeCase* (VAR n: DevCPT.Node); + VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node; + BEGIN + IF n # NIL THEN + min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n; + Evaluate(n, min, max, num, dist, head); + limit := 6 * num; + IF limit < 100 THEN limit := 100 END; + IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN + INCL(n.conval.setval, useTable) + ELSE + IF num > 4 THEN Rebuild(n, head) END; + INCL(n.conval.setval, useTree); + OptimizeCase(n.left); + OptimizeCase(n.right) + END + END + END OptimizeCase; +(* + PROCEDURE ShowTree (n: DevCPT.Node; opts: SET); + BEGIN + IF n # NIL THEN + IF opts = {} THEN opts := n.conval.setval END; + IF useTable IN opts THEN + IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END; + DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END + ELSIF useTree IN opts THEN + DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")") + ELSE + ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW(" "); ShowTree(n.right, opts) + END + END + END ShowTree; +*) +BEGIN + zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0; + one := DevCPT.NewConst(); one.intval := 1; one.realval := 0; + two := DevCPT.NewConst(); two.intval := 2; two.realval := 0; + dummy := DevCPT.NewConst(); + quot := DevCPT.NewConst() +END DevCPB. diff --git a/Trurl-based/Dev/Mod/CPC486.txt b/Trurl-based/Dev/Mod/CPC486.txt new file mode 100644 index 0000000..1a952d9 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPC486.txt @@ -0,0 +1,2333 @@ +MODULE DevCPC486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPC486.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPL486; + + CONST + initializeAll = FALSE; (* initialize all local variable to zero *) + initializeOut = FALSE; (* initialize all OUT parameters to zero *) + initializeDyn = FALSE; (* initialize all open array OUT parameters to zero *) + initializeStr = FALSE; (* initialize rest of string value parameters to zero *) + + FpuControlRegister = 33EH; (* value for fpu control register initialization *) + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + VString16to8 = 29; VString8 = 30; VString16 = 31; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + getrfn = 26; putrfn = 27; + min = 34; max = 35; typ = 36; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + false = 0; true = 1; nil = 0; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI}; + + (* GenShiftOp *) + ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H; + + (* GenBitOp *) + BT = 20H; BTS = 28H; BTR = 30H; + + (* GenFDOp *) + FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H; + + (* GenFMOp *) + FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H; + + (* GenCode *) + SAHF = 9EH; WAIT = 9BH; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* sysflag *) + untagged = 1; callback = 2; noAlign = 3; union = 7; + interface = 10; ccall = -10; guarded = 10; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* pointer init limits *) + MaxPtrs = 10; MaxPush = 4; + + Tag0Offset = 12; + Mth0Offset = -4; + ArrDOffs = 8; + numPreIntProc = 2; + + stackAllocLimit = 2048; + + + VAR + imLevel*: ARRAY 64 OF BYTE; + intHandler*: DevCPT.Object; + inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN; + WReg, BReg, AllReg: SET; FReg: INTEGER; + ptrTab: ARRAY MaxPtrs OF INTEGER; + stkAllocLbl: DevCPL486.Label; + procedureUsesFpu: BOOLEAN; + + + PROCEDURE Init* (opt: SET); + CONST chk = 0; achk = 1; hint = 29; + BEGIN + inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt; + hints := hint IN opt; + stkAllocLbl := DevCPL486.NewLbl + END Init; + + PROCEDURE Reversed (cond: BYTE): BYTE; (* reversed condition *) + BEGIN + IF cond = lss THEN RETURN gtr + ELSIF cond = gtr THEN RETURN lss + ELSIF cond = leq THEN RETURN geq + ELSIF cond = geq THEN RETURN leq + ELSE RETURN cond + END + END Reversed; + + PROCEDURE Inverted (cc: INTEGER): INTEGER; (* inverted sense of condition code *) + BEGIN + IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END + END Inverted; + + PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN); + BEGIN + IF reversed THEN rel := Reversed(rel) END; + CASE rel OF + false: x.offset := ccNever + | true: x.offset := ccAlways + | eql: x.offset := ccE + | neq: x.offset := ccNE + | lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END + | leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END + | gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END + | geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END + END; + x.mode := Cond; x.form := Bool; x.reg := 0; + IF reversed THEN x.reg := 1 END; + IF signed THEN INC(x.reg, 2) END + END setCC; + + PROCEDURE StackAlloc*; (* pre: len = CX bytes; post: len = CX words *) + BEGIN + DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE) + END StackAlloc; + + PROCEDURE^ CheckAv* (reg: INTEGER); + + PROCEDURE AdjustStack (val: INTEGER); + VAR c, sp: DevCPL486.Item; + BEGIN + IF val < -stackAllocLimit THEN + CheckAv(CX); + DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp); + StackAlloc + ELSIF val # 0 THEN + DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE) + END + END AdjustStack; + + PROCEDURE DecStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END + END DecStack; + + PROCEDURE IncStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END + END IncStack; + + (*-----------------register handling------------------*) + + PROCEDURE SetReg* (reg: SET); + BEGIN + AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8 + END SetReg; + + PROCEDURE CheckReg*; + VAR reg: SET; + BEGIN + reg := AllReg - WReg; + IF reg # {} THEN + DevCPM.err(-777); (* register not released *) + IF AX IN reg THEN DevCPM.LogWStr(" AX") END; + IF BX IN reg THEN DevCPM.LogWStr(" BX") END; + IF CX IN reg THEN DevCPM.LogWStr(" CX") END; + IF DX IN reg THEN DevCPM.LogWStr(" DX") END; + IF SI IN reg THEN DevCPM.LogWStr(" SI") END; + IF DI IN reg THEN DevCPM.LogWStr(" DI") END; + WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4) + END; + IF FReg < 8 THEN DevCPM.err(-778); FReg := 8 (* float register not released *) + ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8 + END + END CheckReg; + + PROCEDURE CheckAv* (reg: INTEGER); + BEGIN + ASSERT(reg IN WReg) + END CheckAv; + + PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR n: INTEGER; s, s1: SET; + BEGIN + CASE f OF + | Byte, Bool, Char8, Int8: + s := BReg * {0..3} - stop; + IF (high IN stop) OR (high IN hint) & (s - hint # {}) THEN n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + IF s - hint # {} THEN s := s - hint END; + WHILE ~(n IN s) DO INC(n) END + ELSE + s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4); + IF s1 # {} THEN s := s1 END; + WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END; + IF ~(n IN s) THEN n := n + 4 END + END; + EXCL(BReg, n); EXCL(WReg, n MOD 4) + | Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: + s := WReg - stop; + IF high IN stop THEN s := s * {0..3} END; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END; + s1 := s - hint; + IF high IN hint THEN s1 := s1 * {0..3} END; + IF s1 # {} THEN s := s1 END; + IF 0 IN s THEN n := 0 + ELSIF 2 IN s THEN n := 2 + ELSIF 6 IN s THEN n := 6 + ELSIF 7 IN s THEN n := 7 + ELSIF 1 IN s THEN n := 1 + ELSE n := 3 + END; + EXCL(WReg, n); + IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END + | Real32, Real64: + IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END; + DEC(FReg); n := 0 + END; + DevCPL486.MakeReg(x, n, f); + END GetReg; + + PROCEDURE FreeReg (n, f: INTEGER); + BEGIN + IF f <= Int8 THEN + INCL(BReg, n); + IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END + ELSIF f IN realSet THEN + INC(FReg) + ELSIF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeReg; + + PROCEDURE FreeWReg (n: INTEGER); + BEGIN + IF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeWReg; + + PROCEDURE Free* (VAR x: DevCPL486.Item); + BEGIN + CASE x.mode OF + | Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END + | Ind: FreeWReg(x.reg); + IF x.scale # 0 THEN FreeWReg(x.index) END + | Reg: FreeReg(x.reg, x.form); + IF x.form = Int64 THEN FreeWReg(x.index) END + ELSE + END + END Free; + + PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *) + BEGIN + IF x.mode = Reg THEN + IF x.form = Int64 THEN FreeWReg(x.index) + ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4) + END + END + END FreeHi; + + PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *) + BEGIN + IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END; + IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop)) + ELSIF x.form IN realSet THEN RETURN ~(float IN stop) + ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop) + ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop)) + END + END Fits; + + PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR rh: DevCPL486.Item; + BEGIN + IF f = Int64 THEN + GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r); + GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh); + r.form := Int64; r.index := rh.reg + ELSE + IF f < Int16 THEN INCL(stop, high) END; + GetReg(r, f, hint, stop); DevCPL486.GenPop(r) + END + END Pop; + + PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *) + VAR r: DevCPL486.Item; f: BYTE; + BEGIN + f := x.typ.form; + IF x.mode = Con THEN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END; + IF con IN stop THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + ELSIF x.mode = Stk THEN + IF f IN realSet THEN + GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form) + ELSE + Pop(r, f, hint, stop) + END; + x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f + ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN + Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := Int32 + ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + Free(x); GetReg(r, f, hint, stop); + IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + END Load; + + PROCEDURE Push* (VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; + BEGIN + IF x.form IN realSet THEN + Load(x, {}, {}); DecStack(x.form); + Free(x); x.mode := Stk; + IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END; + DevCPL486.GenFStore(x, TRUE) + ELSIF x.form = Int64 THEN + Free(x); x.form := Int32; y := x; + IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END; + DevCPL486.GenPush(y); DevCPL486.GenPush(x); + x.mode := Stk; x.form := Int64 + ELSE + IF x.form < Int16 THEN Load(x, {}, {high}) + ELSIF x.form = Int16 THEN Load(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x); x.mode := Stk + END + END Push; + + PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN + IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x) + ELSE Load(x, hint, stop); + END + ELSE + CASE x.mode OF + | Var, VarPar: IF ~(mem IN stop) THEN RETURN END + | Con: IF ~(con IN stop) THEN RETURN END + | Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Stk: IF ~(stk IN stop) THEN RETURN END + | Reg: IF Fits(x, stop) THEN RETURN END + ELSE RETURN + END; + IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x) + ELSE Load(x, hint, stop) + END + END + END Assert; + + (*------------------------------------------------*) + + PROCEDURE LoadR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN + Free(x); DevCPL486.GenFLoad(x); + IF x.mode = Stk THEN IncStack(x.form) END; + GetReg(x, Real32, {}, {}) + END + END LoadR; + + PROCEDURE PushR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN LoadR(x) END; + DecStack(x.form); + Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE) + END PushR; + + PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSE + Free(x); GetReg(r, x.form, hint, stop); + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg + END + END LoadW; + + PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop); + IF (x.form < Int32) OR (x.form = Char16) THEN + r := x; x.form := Int32; DevCPL486.GenExtMove(r, x) + END + ELSE + Free(x); + IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END; + IF x.mode = Con THEN x.form := r.form END; + IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := r.form + END + END LoadL; + + PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r, rh, c: DevCPL486.Item; offs: INTEGER; + BEGIN + IF x.form = Int64 THEN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSIF x.mode = Reg THEN + FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop); + FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop); + x.form := Int32; DevCPL486.GenMove(x, r); + x.reg := x.index; DevCPL486.GenMove(x, rh); + x.reg := r.reg; x.index := rh.reg + ELSE + GetReg(rh, Int32, hint, stop + {AX}); + Free(x); + GetReg(r, Int32, hint, stop); + x.form := Int32; offs := x.offset; + IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END; + DevCPL486.GenMove(x, rh); + x.offset := offs; + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.index := rh.reg + END + ELSE + LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh); + x.index := rh.reg + END; + x.form := Int64 + END LoadLong; + + (*------------------------------------------------*) + + PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET); + BEGIN + ASSERT(x.mode = Reg); + GetReg(y, x.form, hint, stop); + DevCPL486.GenMove(x, y) + END CopyReg; + + PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = DInd THEN + x.mode := Ind + ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN + x.mode := Reg + ELSE + Free(x); GetReg(r, Pointer, hint, stop); + IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := Pointer + END; + x.form := Pointer; x.typ := DevCPT.anyptrtyp; + Assert(x, hint, stop) + END GetAdr; + + PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN); + VAR r, v: DevCPL486.Item; + BEGIN + IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer + ELSIF niltest THEN + GetAdr(x, {}, {mem, stk}); + DevCPL486.MakeReg(r, AX, Int32); + v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg; + DevCPL486.GenTest(r, v) + ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer + ELSE GetAdr(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x) + END PushAdr; + + PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET); + VAR n: BYTE; + BEGIN + a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ; + IF lev = DevCPL486.level THEN a.reg := BP + ELSE + a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev])); + WHILE n > 0 DO + a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n) + END + END + END LevelBase; + + PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *) + BEGIN + IF x.tmode = VarPar THEN + LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr; + ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind)); + len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32 + END; + INC(len.offset, typ.n * 4 + 4); + IF typ.sysflag = stackArray THEN len.offset := -4 END + END LenDesc; + + PROCEDURE Tag* (VAR x, tag: DevCPL486.Item); + VAR typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ) + ELSIF x.typ.form = Pointer THEN + ASSERT(x.mode = Reg); + tag.mode := Ind; tag.reg := x.reg; tag.offset := -4; + IF x.typ.sysflag = interface THEN tag.offset := 0 END + ELSIF x.tmode = VarPar THEN + LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4; + Free(tag) (* ??? *) + ELSIF x.tmode = Ind THEN + ASSERT(x.mode = Ind); + tag := x; tag.offset := -4 + ELSE + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ) + END; + tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp + END Tag; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN; + VAR fld: DevCPT.Object; + BEGIN + WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END; + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + REPEAT + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) + OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END; + fld := fld.link + END; + typ := typ.BaseTyp + UNTIL typ = NIL + END; + RETURN FALSE + END ContainsIPtrs; + + PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item); + VAR cv: DevCPT.Const; + BEGIN + IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END; + cv := DevCPT.NewConst(); + cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str; + DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp + END GuidFromString; + + PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END + END; + IF x.mode # Reg THEN + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + ELSE r := x + END; + IF nilTest THEN + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + DevCPL486.GenPush(r); p := r; + IF x.mode # Reg THEN Free(r) END; + GetReg(r, Pointer, {}, {}); + p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r); + p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPAddRef; + + PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END + END; + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + DevCPL486.MakeConst(c, 0, Pointer); + IF nilTest THEN + DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nilSet THEN DevCPL486.GenMove(c, p) END; + DevCPL486.GenPush(r); + p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r); + p.offset := 8; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPRelease; + + PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN + DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ; + WHILE typ.comp = DynArr DO (* complete dynamic array iterations *) + LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + END; + n := x.scale; i := 0; + WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END; + IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *) + DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n + END + END; + CASE x.mode OF + Var, VarPar: + lev := x.obj.mnolev; + IF lev <= 0 THEN + x.mode := Abs + ELSE + LevelBase(y, lev, hint, stop); + IF x.mode # VarPar THEN + x.mode := Ind + ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN + x.mode := DInd; x.offset := x.obj.adr + ELSE + y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind + END; + x.reg := y.reg + END; + x.form := x.typ.form + | LProc, XProc, IProc: + x.mode := Con; x.offset := 0; x.form := ProcTyp + | TProc, CProc: + x.form := ProcTyp + | Ind, Abs, Stk, Reg: + IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END + END + END Prepare; + + PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object); + BEGIN + INC(x.offset, field.adr); x.tmode := Con + END Field; + + PROCEDURE DeRef* (VAR x: DevCPL486.Item); + VAR btyp: DevCPT.Struct; + BEGIN + x.mode := Ind; x.tmode := Ind; x.scale := 0; + btyp := x.typ.BaseTyp; + IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0 + ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size + ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 + ELSE x.offset := 0 + END + END DeRef; + + PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *) + VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER; + BEGIN + btyp := x.typ.BaseTyp; elsize := btyp.size; + IF elsize = 0 THEN Free(y) + ELSIF x.typ.comp = Array THEN + len.mode := Con; len.obj := NIL; + IF y.mode = Con THEN + INC(x.offset, y.offset * elsize) + ELSE + Load(y, hint, stop + {mem, stk, short}); + IF inxchk THEN + DevCPL486.MakeConst(len, x.typ.n, Int32); + DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap) + END; + IF x.scale = 0 THEN x.index := y.reg + ELSE + IF x.scale MOD elsize # 0 THEN + IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4 + ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2 + ELSE elsize := 1 + END; + DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32); + DevCPL486.GenMul(len, y, FALSE) + END; + DevCPL486.MakeConst(len, x.scale DIV elsize, Int32); + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END; + x.scale := elsize + END; + x.tmode := Con + ELSE (* x.typ.comp = DynArr *) + IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END; + LenDesc(x, len, x.typ); + IF x.scale # 0 THEN + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE) + END; + IF (y.mode # Con) OR (y.offset # 0) THEN + IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN + Load(y, hint, stop + {mem, stk, con, short}) + ELSE y.form := Int32 + END; + IF inxchk & ~x.typ.untagged THEN + DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap) + END; + IF (y.mode = Con) & (btyp.comp # DynArr) THEN + INC(x.offset, y.offset * elsize) + ELSIF x.scale = 0 THEN + WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END; + x.index := y.reg; x.scale := btyp.size + ELSE + DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END + END; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END + END + END Index; + + PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN); + VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END; + IF ~guard & typ.untagged THEN DevCPM.err(139) + ELSIF ~guard OR typchk & ~typ.untagged THEN + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + IF (x.typ.form = Pointer) & (x.mode # Reg) THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag) + ELSE Tag(x, tag) + END; + IF ~guard THEN Free(x) END; + IF ~equal THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r); + tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev + END; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + IF guard THEN + IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END + ELSE setCC(x, eql, FALSE, FALSE) + END + END + END + END TypTest; + + PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct); + VAR tag, tdes: DevCPL486.Item; + BEGIN + (* tag must be in AX ! *) + IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END; + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + setCC(x, eql, FALSE, FALSE) + END + END ShortTypTest; + + PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER); + VAR c: DevCPL486.Item; + BEGIN + ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4)); + IF ranchk & (x.mode # Con) THEN + DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x); + IF min # 0 THEN + DevCPL486.GenAssert(ccLE, ranTrap); + c.offset := min; DevCPL486.GenComp(c, x); + DevCPL486.GenAssert(ccGE, ranTrap) + ELSIF max # 0 THEN + DevCPL486.GenAssert(ccBE, ranTrap) + ELSE + DevCPL486.GenAssert(ccNS, ranTrap) + END + END + END Check; + + PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN); + VAR c: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *) + END; + DevCPL486.GenFMOp(1FCH); (* FRNDINT *) + DevCPL486.GenFMOp(0D1H); (* FCOM *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.AllocConst(c, DevCPL486.one, Real32); + DevCPL486.GenFDOp(FSUB, c); + DevCPL486.SetLabel(local); + END Floor; + + PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + BEGIN + IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END; + DevCPL486.GenFStore(x, TRUE); + IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END + END Entier; + + PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *) + (* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *) + VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item; + BEGIN + f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk}); + IF y.form IN {Real32, Real64} THEN + IF f IN {Real32, Real64} THEN + IF m = Undef THEN + IF (y.form = Real64) & (f = Real32) THEN + IF y.mode # Reg THEN LoadR(y) END; + Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE) + END + ELSE + IF y.mode # Reg THEN LoadR(y) END; + IF m = Stk THEN DecStack(f) END; + IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END; + END + ELSE (* x not real *) + IF sysval THEN + IF y.mode = Reg THEN Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN + x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f + ELSE + ASSERT(y.form # Real64); + DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32; + IF m # Stk THEN + Pop(y, y.form, hint, stop); + IF f < Int16 THEN ASSERT(y.reg < 4) END; + y.form := f; + IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END + END + END + ELSE (* y.mode # Reg *) + y.form := f; + IF m # Undef THEN LoadW(y, hint, stop); Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END + END + END + ELSE (* not sysval *) + IF y.mode # Reg THEN LoadR(y) END; + Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN + Entier(x, y.typ, hint, stop); + ELSE + DecStack(f); y.mode := Stk; + IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END; + IF m = Stk THEN Entier(y, y.typ, {}, {}) + ELSIF m = Undef THEN Entier(y, y.typ, hint, stop) + ELSE Entier(y, y.typ, hint, stop + {stk}) + END; + IF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y) + END; + y.form := f; + IF (m # Undef) & (m # Stk) THEN + IF f = Int64 THEN + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + Free(y); DevCPL486.GenMove(y, x); + END + END + END + END + END + ELSE (* y not real *) + IF sysval THEN + IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END; + IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END + ELSE + CASE y.form OF + | Byte, Bool: + IF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char8: + IF f = Int8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, 0, 0) + ELSIF f = Char16 THEN (* ok *) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int32 THEN LoadL(y, hint, stop) + END + | Int8: + IF f = Char8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Int16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 0) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop) + END + | Int32, Set, Pointer, ProcTyp: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, -32768, 32767) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + END + | Int64: + IF f IN {Bool..Int32, Char16} THEN + (* make range checks !!! *) + FreeHi(y) + END + END + END; + IF f IN {Real32, Real64} THEN + IF sysval THEN + IF (m # Undef) & (m # Reg) THEN + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) + ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f + END + ELSE + IF y.mode = Reg THEN Push(y) END; + y.form := f; + IF m = Reg THEN LoadR(y) END + END + ELSE (* not sysval *) (* int -> float *) + IF y.mode = Reg THEN Push(y) END; + IF m = Stk THEN + Free(y); DevCPL486.GenFLoad(y); s := -4; + IF f = Real64 THEN DEC(s, 4) END; + IF y.mode = Stk THEN + IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END + END; + IF s # 0 THEN AdjustStack(s) END; + GetReg(y, Real32, {}, {}); + Free(y); DevCPL486.GenFStore(x, TRUE) + ELSIF m = Reg THEN + LoadR(y) + ELSIF m # Undef THEN + LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) + END + END + ELSE + y.form := f; + IF m = Stk THEN + IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END; + Push(y) + ELSIF m # Undef THEN + IF f = Int64 THEN + IF y.mode # Reg THEN LoadLong(y, hint, stop) END; + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); DevCPL486.GenMove(y, x) + END + END + END + END + END ConvMove; + + PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *) + VAR y: DevCPL486.Item; + BEGIN + ASSERT(x.mode # Con); + IF (size >= 0) + & ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4)) + OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END; +(* + IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form IN {Comp, Int64})) THEN DevCPM.err(220) END; +*) + y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop) + END Convert; + + PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET); + VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item; + BEGIN + IF mem IN stop THEN GetReg(x, Bool, hint, stop) END; + IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *) + DevCPL486.GenSetCC(y.offset, x) + ELSE + end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl; + DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *) + DevCPL486.SetLabel(F); + DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x); + DevCPL486.GenJump(ccAlways, end, TRUE); + DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); + DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x); + DevCPL486.SetLabel(end) + END; + IF x.mode # Reg THEN Free(x) END + END LoadCond; + + PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con)); + CASE subcl OF + | eql..geq: + DevCPL486.GenComp(y, x); Free(x); + setCC(x, subcl, rev, x.typ.form IN {Int8..Int32}) + | times: + IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END + | slash: + DevCPL486.GenXor(y, x) + | plus: + IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END + | minus, msk: + IF (x.form = Set) OR (subcl = msk) THEN (* and not *) + IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *) + ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *) + ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *) + ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *) + END + ELSE (* minus *) + IF rev THEN (* y - x *) + IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x) + ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *) + END + ELSE (* x - y *) + DevCPL486.GenSub(y, x, ovflchk) + END + END + | min, max: + local := DevCPL486.NewLbl; + DevCPL486.GenComp(y, x); + IF subcl = min THEN + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE) + ELSE DevCPL486.GenJump(ccLE, local, TRUE) + END + ELSE + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE) + ELSE DevCPL486.GenJump(ccGE, local, TRUE) + END + END; + DevCPL486.GenMove(y, x); + DevCPL486.SetLabel(local) + END; + Free(y); + IF x.mode # Reg THEN Free(x) END + END IntDOp; + + PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *) + BEGIN + ASSERT(x.form = Int64); + IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END; + Free(x); Free(y); x.form := Int32; y.form := Int32; + IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END; + INC(x.offset, 4); + IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END; + IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END; + END LargeInc; + + PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; a, b: DevCPL486.Item; + BEGIN + ASSERT(x.mode = Reg); + IF y.form = Int64 THEN LoadR(y) END; + IF y.mode = Reg THEN rev := ~rev END; + CASE subcl OF + | eql..geq: DevCPL486.GenFDOp(FCOMP, y) + | times: DevCPL486.GenFDOp(FMUL, y) + | slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END + | plus: DevCPL486.GenFDOp(FADD, y) + | minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END + | min, max: + IF y.mode = Reg THEN + DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *) + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END; + DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *) + ELSE + DevCPL486.GenFDOp(FCOM, y); + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END; + DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *) + DevCPL486.GenFLoad(y); + DevCPL486.SetLabel(local) + END + (* largeint support *) + | div: + IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END; + Floor(y, FALSE) + | mod: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1F8H); (* FPREM *) + DevCPL486.GenFMOp(1E4H); (* FTST *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX}); + DevCPL486.GenMove(a, b); + DevCPL486.GenFMOp(0D1H); (* FCOM *) + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenXor(b, a); Free(b); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.GenFMOp(0C1H); (* FADD ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + | ash: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1FDH); (* FSCALE *) + Floor(y, TRUE) + END; + IF y.mode = Stk THEN IncStack(y.form) END; + Free(y); + IF (subcl >= eql) & (subcl <= geq) THEN + Free(x); CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + setCC(x, subcl, rev, FALSE) + END + END FloatDOp; + + PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + VAR L: DevCPL486.Label; c: DevCPL486.Item; + BEGIN + CASE subcl OF + | minus: + IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END + | abs: + L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccNS, L, TRUE); + DevCPL486.GenNeg(x, ovflchk); + DevCPL486.SetLabel(L) + | cap: + DevCPL486.MakeConst(c, -1 - 20H, x.form); + DevCPL486.GenAnd(c, x) + | not: + DevCPL486.MakeConst(c, 1, x.form); + DevCPL486.GenXor(c, x) + END; + IF x.mode # Reg THEN Free(x) END + END IntMOp; + + PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + BEGIN + ASSERT(x.mode = Reg); + IF subcl = minus THEN DevCPL486.GenFMOp(FCHS) + ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS) + END + END FloatMOp; + + PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET); + (* range neg result + F F {x} + F T -{x} + T F {x..31} + T T -{0..x} *) + VAR c, r: DevCPL486.Item; val: INTEGER; + BEGIN + IF x.mode = Con THEN + IF range THEN + IF neg THEN val := -2 ELSE val := -1 END; + x.offset := SYSTEM.LSH(val, x.offset) + ELSE + val := 1; x.offset := SYSTEM.LSH(val, x.offset); + IF neg THEN x.offset := -1 - x.offset END + END + ELSE + Check(x, 0, 31); + IF neg THEN val := -2 + ELSIF range THEN val := -1 + ELSE val := 1 + END; + DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r); + IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END; + Free(x); x.reg := r.reg + END; + x.typ := DevCPT.settyp; x.form := Set + END MakeSet; + + PROCEDURE MakeCond* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Con THEN + setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE) + ELSE + DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); Free(x); + setCC(x, neq, FALSE, FALSE) + END + END MakeCond; + + PROCEDURE Not* (VAR x: DevCPL486.Item); + VAR a: INTEGER; + BEGIN + x.offset := Inverted(x.offset); (* invert cc *) + END Not; + + PROCEDURE Odd* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END; + Free(x); DevCPL486.MakeConst(c, 1, x.form); + IF x.mode = Reg THEN + IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END; + DevCPL486.GenAnd(c, x) + ELSE + c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x) + END; + setCC(x, neq, FALSE, FALSE) + END Odd; + + PROCEDURE In* (VAR x, y: DevCPL486.Item); + BEGIN + IF y.form = Set THEN Check(x, 0, 31) END; + DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y); + setCC(x, lss, FALSE, FALSE); (* carry set *) + END In; + + PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *) + VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER; + BEGIN + IF subcl = ash THEN opl := SHL; opr := SAR + ELSIF subcl = lsh THEN opl := SHL; opr := SHR + ELSE opl := ROL; opr := ROR + END; + IF y.mode = Con THEN + IF y.offset > 0 THEN + DevCPL486.GenShiftOp(opl, y, x) + ELSIF y.offset < 0 THEN + y.offset := -y.offset; + DevCPL486.GenShiftOp(opr, y, x) + END + ELSE + ASSERT(y.mode = Reg); + Check(y, -31, 31); + L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; + DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y); + DevCPL486.GenJump(ccNS, L1, TRUE); + DevCPL486.GenNeg(y, FALSE); + DevCPL486.GenShiftOp(opr, y, x); + DevCPL486.GenJump(ccAlways, L2, TRUE); + DevCPL486.SetLabel(L1); + DevCPL486.GenShiftOp(opl, y, x); + DevCPL486.SetLabel(L2); + Free(y) + END; + IF x.mode # Reg THEN Free(x) END + END Shift; + + PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN); + VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN; + BEGIN + ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE; + IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END; + DevCPL486.GenDiv(y, mod, pos); Free(y); + IF mod THEN + r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *) + END + END DivMod; + + PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *) + BEGIN + IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset) + ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset + END; + x.scale := 0; x.typ := typ; x.form := typ.form + END Mem; + + PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *) + BEGIN + IF len.mode = Con THEN + IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END + ELSE + Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len) + END; + FreeWReg(SI); FreeWReg(DI) + END SysMove; + + PROCEDURE Len* (VAR x, y: DevCPL486.Item); + VAR typ: DevCPT.Struct; dim: INTEGER; + BEGIN + dim := y.offset; typ := x.typ; + IF typ.untagged THEN DevCPM.err(136) END; + WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END; + LenDesc(x, x, typ); + END Len; + + PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER; + BEGIN + CASE x.form OF + | String8, VString8: RETURN 1 + | String16, VString16: RETURN 2 + | VString16to8: RETURN 0 + | Comp: RETURN x.typ.BaseTyp.size + END + END StringWSize; + + PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN); + VAR sw, dw: INTEGER; + BEGIN + CheckAv(CX); + IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN + DevCPL486.GenBlockComp(4, 4) + ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index) + ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index) + ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index) + ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index) + ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x)) + END; + FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE); + END CmpString; + + PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item); + VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct; + BEGIN + atyp := y.typ; + WHILE ftyp.comp = DynArr DO + IF ftyp.BaseTyp = DevCPT.bytetyp THEN + IF atyp.comp = DynArr THEN + IF atyp.untagged THEN DevCPM.err(137) END; + LenDesc(y, len, atyp); + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z); + len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp; + WHILE atyp.comp = DynArr DO + LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE); + IF y.tmode = VarPar THEN Free(z) END; (* ??? *) + atyp := atyp.BaseTyp + END; + DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE); + Free(len) + ELSE + DevCPL486.MakeConst(len, atyp.size, Int32) + END + ELSE + IF atyp.comp = DynArr THEN LenDesc(y, len, atyp); + IF atyp.untagged THEN DevCPM.err(137) END; + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + ELSE DevCPL486.MakeConst(len, atyp.n, Int32) + END + END; + DevCPL486.GenPush(len); + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END + END VarParDynArr; + + PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *) + BEGIN + IF y.mode = Con THEN + IF y.form IN {Real32, Real64} THEN + DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {}); + IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *) + ELSIF x.form = Int64 THEN + ASSERT(x.mode IN {Ind, Abs}); + y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x); + y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x); + DEC(x.offset, 4); x.form := Int64 + ELSE + DevCPL486.GenMove(y, x) + END + ELSE + IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(x.form = Pointer); + GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer + END; + IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END; + ConvMove(x, y, FALSE, {}, {}) + END; + Free(x) + END Assign; + + PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET); + VAR c: DevCPL486.Item; + BEGIN + IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSE len.mode := Con + END; + len.typ := DevCPT.int32typ + END ArrayLen; + +(* +(!) src dest zero +sx = sy x b y b +SHORT(lx) = sy x b+ x w y b +SHORT(lx) = SHORT(ly) x b+ x w y b+ + +lx = ly x w y w +LONG(sx) = ly x b y w * +LONG(SHORT(lx)) = ly x b+ x w* y w * + +sx := sy y b x b +sx := SHORT(ly) y b+ y w x b + +lx := ly y w x w +lx := LONG(sy) y b x w * +lx := LONG(SHORT(ly)) y b+ y w* x w * +(!)*) + + PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *) + BEGIN + IF (x.typ.comp = DynArr) & x.typ.untagged THEN + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1) + ELSE + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0) + END; + FreeWReg(SI); FreeWReg(DI) + END AddCopy; + + PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *) + VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item; + BEGIN + sx := x.typ.size; CheckAv(CX); + IF y.form IN {String8, String16} THEN + sy := y.index * y.typ.BaseTyp.size; + IF x.typ.comp = Array THEN (* adjust size for optimal performance *) + sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4; + IF sy4 <= sx THEN sy := sy4 + ELSIF sy2 <= sx THEN sy := sy2 + ELSIF sy > sx THEN DevCPM.err(114); sy := 1 + END + ELSIF inxchk & ~x.typ.untagged THEN (* check array length *) + Free(x); LenDesc(x, c, x.typ); + DevCPL486.MakeConst(y, y.index, Int32); + DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap); + Free(c) + END; + DevCPL486.GenBlockMove(1, sy) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1) + ELSE + Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c); + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0) + END + ELSIF y.form IN {VString16to8, VString8, VString16} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + ASSERT(y.mode # Stk) + ELSIF short THEN (* COPY *) + sy := y.typ.size; + IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END; + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + IF y.mode = Stk THEN AdjustStack(sy) END + ELSE (* := *) + IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END; + IF y.mode = Stk THEN AdjustStack(sy) END + END; + FreeWReg(SI); FreeWReg(DI) + END Copy; + + PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + CheckAv(AX); CheckAv(CX); + DevCPL486.GenStringLength(typ.BaseTyp.size, -1); + Free(x); GetReg(x, Int32, {}, wreg - {CX}); + DevCPL486.GenNot(x); + IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END; + FreeWReg(DI) + END StrLen; + + PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *) + VAR c: DevCPL486.Item; + BEGIN + IF y.mode = Con THEN fact := fact * y.offset + ELSE + IF ranchk OR inxchk THEN + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap) + END; + DevCPL486.GenPush(y); + IF z.mode = Con THEN z := y + ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y) + END + END + END MulDim; + + PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *) + (* y const or on stack *) + VAR z: DevCPL486.Item; end: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) & (x.form = Pointer)); + z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32; + IF y.mode = Con THEN y.form := Int32 + ELSE Pop(y, Int32, {}, {}) + END; + end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *) + DevCPL486.GenMove(y, z); + DevCPL486.SetLabel(end); + IF y.mode = Reg THEN Free(y) END + END SetDim; + + PROCEDURE SysNew* (VAR x: DevCPL486.Item); + BEGIN + DevCPM.err(141) + END SysNew; + + PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER); + (* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *) + VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label; + BEGIN + typ := x.typ.BaseTyp; + IF typ.untagged THEN DevCPM.err(138) END; + IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ); + IF ContainsIPtrs(typ) THEN INC(tag.offset) END; + DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewRec; + ELSE eltyp := typ.BaseTyp; + IF typ.comp = Array THEN + nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n + ELSE (* DynArr *) + nofdim := typ.n+1; + WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END + END ; + WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END; + IF eltyp.comp = Record THEN + IF eltyp.untagged THEN DevCPM.err(138) END; + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp); + IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END; + ELSIF eltyp.form = Pointer THEN + IF ~eltyp.untagged THEN + DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *) + ELSIF eltyp.sysflag = interface THEN + DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *) + ELSE + DevCPL486.MakeConst(tag, 12, Pointer) + END + ELSE (* eltyp is pointerless basic type *) + CASE eltyp.form OF + | Undef, Byte, Char8: n := 1; + | Int16: n := 2; + | Int8: n := 3; + | Int32: n := 4; + | Bool: n := 5; + | Set: n := 6; + | Real32: n := 7; + | Real64: n := 8; + | Char16: n := 9; + | Int64: n := 10; + | ProcTyp: n := 11; + END; + DevCPL486.MakeConst(tag, n, Pointer) +(* + DevCPL486.MakeConst(tag, eltyp.size, Pointer) +*) + END; + IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL + ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk) + END; + DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p); + DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewArr; + END; + DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX}); + IF typ.comp = DynArr THEN (* set flags for nil test *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x) + ELSIF typ.comp = Record THEN + n := NumOfIntProc(typ); + IF n > 0 THEN (* interface method table pointer setup *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE); + tag.offset := - 4 * (n + numPreIntProc); + p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer; + DevCPL486.GenMove(tag, p); + IF nofel.mode # Con THEN (* unk pointer setup *) + p.offset := 8; + DevCPL486.GenMove(nofel, p); + Free(nofel) + END; + DevCPL486.SetLabel(lbl); + END + END + END New; + + PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *) + VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct; + BEGIN + par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form; + IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END; + IF ap.typ = DevCPT.niltyp THEN + IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN + DevCPM.err(142) + END; + DevCPL486.GenPush(ap) + ELSIF par.typ.comp = DynArr THEN + IF ap.form IN {String8, String16} THEN + IF ~par.typ.untagged THEN + DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c) + END; + ap.mode := Con; DevCPL486.GenPush(ap); + ELSIF ap.form IN {VString8, VString16} THEN + DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a); + IF ~par.typ.untagged THEN + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c); + Free(ap); StrLen(c, ap.typ, TRUE); + DevCPL486.GenPush(c); Free(c) + END; + DevCPL486.GenPush(a) + ELSE + IF ~par.typ.untagged THEN + IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *) + VarParDynArr(par.typ, ap) + END; + PushAdr(ap, niltest) + END + ELSIF fp.mode = VarPar THEN + recTyp := ap.typ; + IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END; + IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN + Tag(ap, tag); + IF rec & (tag.mode # Con) THEN + GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c + END; + DevCPL486.GenPush(tag); + IF tag.mode # Con THEN niltest := FALSE END; + PushAdr(ap, niltest); + IF rec THEN Free(tag) END + ELSE PushAdr(ap, niltest) + END; + tag.typ := recTyp + ELSIF par.form = Comp THEN + s := par.typ.size; + IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN + s := (s + 3) DIV 4 * 4; AdjustStack(-s); + IF ap.form IN {String8, String16} THEN + IF ap.index > 1 THEN (* nonempty string *) + ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4; + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenBlockMove(1, ss); + ELSE + ss := 0; + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c) + END; + IF s > ss THEN + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(1, s - ss) + END; + ELSE + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n); + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(StringWSize(par), 0) + END + ELSE + IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *) + AdjustStack((4 - s) DIV 4 * 4); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c) + ELSE + AdjustStack((-s) DIV 4 * 4); + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + IF ap.form IN {String8, String16} THEN + DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4) + ELSIF ap.form IN {VString8, VString16, VString16to8} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n) + ELSE + DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4) + END + END + END + ELSIF ap.mode = Con THEN + IF ap.form IN {Real32, Real64} THEN (* ??? push const *) + DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE) + ELSE + ap.form := Int32; + IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END; + DevCPL486.GenPush(ap) + END + ELSIF ap.typ.form = Pointer THEN + recTyp := ap.typ.BaseTyp; + IF rec THEN + Load(ap, {}, {}); Tag(ap, tag); + IF tag.mode = Con THEN (* explicit nil test needed *) + DevCPL486.MakeReg(a, AX, Int32); + c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg; + DevCPL486.GenTest(a, c) + END + END; + DevCPL486.GenPush(ap); Free(ap); + tag.typ := recTyp + ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(par.form = Pointer); + PushAdr(ap, FALSE) + ELSE + ConvMove(par, ap, FALSE, {}, {high}); + END + END Param; + + PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item); + VAR r: DevCPL486.Item; + BEGIN + DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *) + IF res.mode = Con THEN + IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res); + ELSIF r.form = Int64 THEN + r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r); + r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r) + ELSE DevCPL486.GenMove(res, r); + END + ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(r.form = Pointer); + GetAdr(res, {}, wreg - {AX}) + ELSE + r.index := DX; (* for int64 *) + ConvMove(r, res, FALSE, wreg - {AX} + {high}, {}); + END; + Free(res) + END Result; + + PROCEDURE InitFpu; + VAR x: DevCPL486.Item; + BEGIN + DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x); + DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *) + DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *) + END InitFpu; + + PROCEDURE PrepCall* (proc: DevCPT.Object); + VAR lev: BYTE; r: DevCPL486.Item; + BEGIN + lev := proc.mnolev; + IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r) + END + END PrepCall; + + PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *) + VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object; + BEGIN + IF x.mode IN {LProc, XProc, IProc} THEN + lev := x.obj.mnolev; saved := FALSE; + IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *) + n := imLevel[DevCPL486.level] - imLevel[lev]; + IF n > 0 THEN + saved := TRUE; + y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4; + DevCPL486.MakeReg(r, BX, Pointer); + WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END + END + END; + DevCPL486.GenCall(x); + IF x.obj.sysflag = ccall THEN (* remove parameters *) + p := x.obj.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + IF saved THEN DevCPL486.GenPop(r) END; + ELSIF x.mode = TProc THEN + IF x.scale = 1 THEN (* super *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp) + ELSIF x.scale = 2 THEN (* static call *) + DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + tag.obj := DevCPE.TypeObj(typ) + ELSIF x.scale = 3 THEN (* interface method call *) + DevCPM.err(200) + END; + IF tag.mode = Con THEN + y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0 + ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *) + y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0; + IF tag.mode = Ind THEN (* nil test *) + DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag) + END + ELSE + IF tag.mode = Reg THEN y.reg := tag.reg + ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y) + END; + y.mode := Ind; y.offset := 0; y.scale := 0 + END; + IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset + ELSIF tag.typ.untagged THEN DevCPM.err(140) + ELSE + IF x.obj.link.typ.sysflag = interface THEN (* correct method number *) + x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset + END; + INC(y.offset, Mth0Offset - 4 * x.offset) + END; + DevCPL486.GenCall(y); Free(y) + ELSIF x.mode = CProc THEN + IF x.obj.link # NIL THEN (* tag = first param *) + IF x.obj.link.mode = VarPar THEN + GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag) + ELSE + (* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *) + Result(x.obj.link, tag) (* use result load for first parameter *) + END + END; + i := 1; n := ORD(x.obj.conval.ext^[0]); + WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END + ELSE (* proc var *) + DevCPL486.GenCall(x); Free(x); + IF x.typ.sysflag = ccall THEN (* remove parameters *) + p := x.typ.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + x.typ := x.typ.BaseTyp + END; + IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128) + & ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *) + InitFpu + END; + CheckReg; + IF x.typ.form = Int64 THEN + GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX}); + x.index := y.reg; x.form := Int64 + ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high}) + END + END Call; + + PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *) + VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct; + BEGIN + IF typ.untagged THEN DevCPM.err(-137) END; + ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer; + DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32); + DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp + END; + ptr.offset := adr; DevCPL486.GenMove(ptr, src); + DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE); + (* CX = length in bytes *) + StackAlloc; + (* CX = length in 32bit words *) + DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr); + DevCPL486.GenBlockMove(4, 0) (* 32bit moves *) + END CopyDynArray; + + PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER); + VAR i, j, x: INTEGER; + BEGIN + (* align *) + i := 1; + WHILE i < n DO + x := tab[i]; j := i-1; + WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END; + tab[j+1] := x; INC(i) + END; + (* eliminate equals *) + i := 1; j := 1; + WHILE i < n DO + IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END; + INC(i) + END; + n := j + END Sort; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form IN {Pointer, ProcTyp} THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END; + INC(num); + IF adr MOD 4 # 0 THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END; + INC(num) + END + ELSIF typ.comp = Record THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.name^ = DevCPM.HdPtrName) OR + (fld.name^ = DevCPM.HdUtPtrName) OR + (fld.name^ = DevCPM.HdProcName) THEN + FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num) + ELSE FindPtrs(fld.typ, fld.adr + adr, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, num); + IF num # i THEN i := 1; + WHILE (i < n) & (num <= MaxPtrs) DO + INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i) + END + END + END + END + END FindPtrs; + + PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item); + VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr; + DevCPL486.MakeReg(y, DI, Int32); + IF par.typ.comp # DynArr THEN + DevCPL486.GenMove(x, y); + lbl := DevCPL486.NewLbl; + IF ODD(par.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zreg, y); + DevCPL486.GenJump(ccE, lbl, TRUE) + END; + size := par.typ.size; + IF size <= 16 THEN + x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0; + WHILE size > 0 DO + IF size = 1 THEN x.form := Int8; s := 1 + ELSIF size = 2 THEN x.form := Int16; s := 2 + ELSE x.form := Int32; s := 4 + END; + zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s) + END; + zreg.form := Int32 + ELSE + DevCPL486.GenBlockStore(1, size) + END; + DevCPL486.SetLabel(lbl) + ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *) + DevCPL486.GenMove(x, y); + DevCPL486.MakeReg(len, CX, Int32); + INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *) + bt := par.typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp + END; + size := bt.size; + IF size MOD 4 = 0 THEN size := size DIV 4; s := 4 + ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2 + ELSE s := 1 + END; + DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE); + DevCPL486.GenBlockStore(s, 0) + END + END InitOutPar; + + PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); + VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER; + BEGIN + op := 0; par := proc.link; + WHILE par # NIL DO (* count out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END; + par := par.link + END; + DevCPL486.MakeConst(zero, 0, Int32); + IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *) + WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END + ELSE + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); + IF size <= 32 THEN (* use PUSH reg *) + WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END + ELSE (* use string store *) + AdjustStack(-size); + DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + DevCPL486.GenBlockStore(1, size) + END; + IF op > 0 THEN + par := proc.link; + WHILE par # NIL DO (* init out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END; + par := par.link + END + END + END + END AllocAndInitAll; + + PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *) + VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + IF ptrinit & (proc.scope # NIL) THEN + nofptrs := 0; obj := proc.scope.scope; (* local variables *) + WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO + FindPtrs(obj.typ, obj.adr, nofptrs); + obj := obj.link + END; + IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN + base := proc.conval.intval2; + Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END; + INC(i) + END; + IF a # base THEN INC(gaps) END; + IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN + DevCPL486.MakeConst(z, 0, Pointer); + IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END; + i := 0; a := size + base; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END; + DevCPL486.GenPush(z); INC(i) + END; + IF a # base THEN AdjustStack(base - a) END + ELSE + AdjustStack(-size); + DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z); + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END + ELSE + AdjustStack(-size) + END + ELSE + nofptrs := 0; + AdjustStack(-size) + END + END AllocAndInitPtrs1; + + PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *) + VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label; + BEGIN + IF ptrinit THEN + zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer); + IF nofptrs > MaxPtrs THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y); + DevCPL486.GenStrStore(size) + END; + obj := proc.link; (* parameters *) + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN + IF ~zeroed THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE + END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + IF ODD(obj.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zero, y); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nofptrs > MaxPtrs THEN + DevCPL486.GenStrStore(obj.typ.size) + ELSE + Sort(ptrTab, nofptrs); + x.reg := DI; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END; + IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END + END + END; + obj := obj.link + END + END + END InitPtrs2; + + PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN; + VAR obj: DevCPT.Object; nofptrs: INTEGER; + BEGIN + IF ptrinit THEN + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN RETURN TRUE END + END; + obj := obj.link + END + END; + RETURN FALSE + END NeedOutPtrInit; + + PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN); + VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER; + BEGIN + procedureUsesFpu := useFpu; + SetReg({AX, CX, DX, SI, DI}); + DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer); + IF proc # NIL THEN (* enter proc *) + DevCPL486.SetLabel(proc.adr); + IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + adr := proc.conval.intval2; size := -adr; + IF isGuarded IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); + r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL; + DevCPL486.GenPush(r1); + intHandler.used := TRUE; + r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler; + DevCPL486.GenPush(r1); + r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenPush(r1); + DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1); + DEC(size, 24) + ELSE + IF imVar IN proc.conval.setval THEN (* set down pointer *) + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4) + END; + IF isCallback IN proc.conval.setval THEN + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8) + END + END; + ASSERT(size >= 0); + IF initializeAll THEN + AllocAndInitAll(proc, adr, size, np) + ELSE + AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *) + InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *) + END; + par := proc.link; (* parameters *) + WHILE par # NIL DO + IF (par.mode = Var) & (par.typ.comp = DynArr) THEN + CopyDynArray(par.adr, par.typ) + END; + par := par.link + END; + IF imVar IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r) + END + END + ELSIF ~empty THEN (* enter module *) + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r) + END; + IF useFpu THEN InitFpu END + END Enter; + + PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN); + VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER; + BEGIN + DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer); + IF proc # NIL THEN (* exit proc *) + IF proc.sysflag # noframe THEN + IF ~empty OR NeedOutPtrInit(proc) THEN + IF isGuarded IN proc.conval.setval THEN (* remove exception frame *) + x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32; + DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r); + x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x); + size := 12 + ELSE + size := 0; + IF imVar IN proc.conval.setval THEN INC(size, 4) END; + IF isCallback IN proc.conval.setval THEN INC(size, 8) END + END; + IF size > 0 THEN + x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32; + DevCPL486.GenLoadAdr(x, sp); + IF size > 4 THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r) + END; + IF size # 8 THEN + DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r) + END + ELSE + DevCPL486.GenMove(fp, sp) + END; + DevCPL486.GenPop(fp) + END; + IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0) + ELSE DevCPL486.GenReturn(proc.conval.intval - 8) + END + END + ELSE (* exit module *) + IF ~empty THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r); + DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp) + END; + DevCPL486.GenReturn(0) + END + END Exit; + + PROCEDURE InstallStackAlloc*; + VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label; + BEGIN + IF stkAllocLbl # DevCPL486.NewLbl THEN + DevCPL486.SetLabel(stkAllocLbl); + DevCPL486.MakeReg(ax, AX, Int32); + DevCPL486.MakeReg(cx, CX, Int32); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.GenPush(ax); + DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE); + l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx); + DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax); + DevCPL486.GenSub(ax, sp, FALSE); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax); + l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE); + l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c); + DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE); + DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE); + DevCPL486.GenJump(ccNE, l1, TRUE); + DevCPL486.SetLabel(l2); + DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE); + x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1; + DevCPL486.GenMove(x, ax); + DevCPL486.GenPush(ax); + DevCPL486.GenMove(x, ax); + DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx); + DevCPL486.GenReturn(0); + name := "$StackAlloc"; DevCPE.OutRefName(name); + END + END InstallStackAlloc; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + DevCPL486.GenAssert(ccNever, n) + END Trap; + + PROCEDURE Jump* (VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(ccAlways, L, FALSE) + END Jump; + + PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(x.offset, L, FALSE); + END JumpT; + + PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(Inverted(x.offset), L, FALSE); + END JumpF; + + PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label); + VAR c: DevCPL486.Item; n: INTEGER; + BEGIN + n := high - low + 1; + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE); + DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccAE, else, FALSE); + DevCPL486.GenCaseJump(x) + END CaseTableJump; + + PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + IF high = low THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END; + DevCPL486.GenJump(ccE, this, FALSE) + ELSIF first THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccL, else, FALSE); + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccLE, this, FALSE); + ELSE + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccG, else, FALSE); + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccGE, this, FALSE); + END + END CaseJump; + +BEGIN + imLevel[0] := 0 +END DevCPC486. diff --git a/Trurl-based/Dev/Mod/CPE.txt b/Trurl-based/Dev/Mod/CPE.txt new file mode 100644 index 0000000..f864ca7 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPE.txt @@ -0,0 +1,1105 @@ +MODULE DevCPE; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPE.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Dates, DevCPM, DevCPT; + + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* object modes *) + Fld = 4; Typ = 5; Head = 12; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6; + mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13; + mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3; + mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; + mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13; + mInterface = 32; mGuid = 33; mResult = 34; + + (* sysflag *) + untagged = 1; noAlign = 3; union = 7; interface = 10; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* kernel flags *) + iptrs = 30; + + expAllFields = TRUE; + + (* implementation restrictions *) + CodeBlocks = 512; + CodeLength = 16384; + MaxNameTab = 800000H; + + useAllRef = FALSE; + outSignatures = TRUE; + + TYPE + CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR; + + VAR + pc*: INTEGER; + dsize*: INTEGER; (* global data size *) + KNewRec*, KNewArr*: DevCPT.Object; + closeLbl*: INTEGER; + CaseLinks*: DevCPT.LinkList; + + processor: INTEGER; + bigEndian: BOOLEAN; + procVarIndirect: BOOLEAN; + idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER; + Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object; + outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN; + codePos, srcPos: INTEGER; + options: SET; + code: ARRAY CodeBlocks OF CodeBlock; + actual: CodeBlock; + actIdx, blkIdx: INTEGER; + CodeOvF: BOOLEAN; + zero: ARRAY 16 OF SHORTCHAR; (* all 0X *) + imports: INTEGER; + dllList, dllLast: DevCPT.Object; + + + PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + CONST N = 4294967296.0; (* 2^32 *) + VAR rh, rl: REAL; + BEGIN + rl := con.intval; rh := con.realval / N; + IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N + ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N + END; + hi := SHORT(ENTIER(rh)); + rl := rl + (rh - hi) * N; + IF rl < 0 THEN hi := hi - 1; rl := rl + N + ELSIF rl >= N THEN hi := hi + 1; rl := rl - N + END; + IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END; + low := SHORT(ENTIER(rl)) +(* + hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0)); + r := con.realval + con.intval - hi * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + low := SHORT(ENTIER(r)) +*) + END GetLongWords; + + PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER); + VAR r: SHORTREAL; + BEGIN + r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r) + END GetRealWord; + + PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + TYPE A = ARRAY 2 OF INTEGER; + VAR a: A; + BEGIN + a := SYSTEM.VAL(A, con.realval); + IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END + END GetRealWords; + + PROCEDURE IsSame (x, y: REAL): BOOLEAN; + BEGIN + RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y)) + END IsSame; + + PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER); + VAR c: DevCPT.Const; + BEGIN + INCL(con.setval, form); + CASE form OF + | String8: + obj := Const8; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END + | String16: + obj := Const16; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END + | Int64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO + c := c.link + END; + IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END + | Real32: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 4) END + | Real64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx64; INC(idx64, 8) END + | Guid: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 16) END + END; + IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END; + con.intval := adr + END AllocConst; + + + PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *) + VAR obj: DevCPT.Object; name: DevCPT.Name; + BEGIN + IF typ.strobj = NIL THEN + name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *) + obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END + END AllocTypDesc; + + + PROCEDURE PutByte* (a, x: INTEGER); + BEGIN + code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256)) + END PutByte; + + PROCEDURE PutShort* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 256); PutByte(a + 1, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256) + END + END PutShort; + + PROCEDURE PutWord* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H); + PutByte(a + 2, x DIV 256); PutByte(a + 3, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256); + PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H) + END + END PutWord; + + PROCEDURE ThisByte* (a: INTEGER): INTEGER; + BEGIN + RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength]) + END ThisByte; + + PROCEDURE ThisShort* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ThisByte(a) * 256 + ThisByte(a+1) + ELSE + RETURN ThisByte(a+1) * 256 + ThisByte(a) + END + END ThisShort; + + PROCEDURE ThisWord* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3) + ELSE + RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a) + END + END ThisWord; + + PROCEDURE GenByte* (x: INTEGER); + BEGIN + IF actIdx >= CodeLength THEN + IF blkIdx < CodeBlocks THEN + NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0 + ELSE + IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END; + actIdx := 0; pc := 0 + END + END; + actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc) + END GenByte; + + PROCEDURE GenShort* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256) + END + END GenShort; + + PROCEDURE GenWord* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H) + END + END GenWord; + + PROCEDURE WriteCode; + VAR i, j, k, n: INTEGER; b: CodeBlock; + BEGIN + j := 0; k := 0; + WHILE j < pc DO + n := pc - j; i := 0; b := code[k]; + IF n > CodeLength THEN n := CodeLength END; + WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END; + INC(j, n); INC(k) + END + END WriteCode; + + + PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList; + VAR link: DevCPT.LinkList; m: DevCPT.Object; + BEGIN + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ)); + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp)); + IF obj.mnolev >= 0 THEN (* not imported *) + CASE obj.mode OF + | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END + | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END + | Var: offs := offs + dsize; obj := Data + | Con, IProc, XProc, LProc: + END + ELSIF obj.mode = Typ THEN + IF obj.typ.untagged THEN (* add desc for imported untagged types *) + IF obj.links = NIL THEN obj.link := descList; descList := obj END + ELSE + m := DevCPT.GlbMod[-obj.mnolev]; + IF m.library # NIL THEN RETURN NIL END (* type import from dll *) + END + END; + link := obj.links; + WHILE (link # NIL) & (link.offset # offs) DO link := link.next END; + IF link = NIL THEN + NEW(link); link.offset := offs; link.linkadr := 0; + link.next := obj.links; obj.links := link + END; + RETURN link + END OffsetLink; + + + PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + obj := typ.strobj; + IF obj = NIL THEN + obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0; + obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END; + RETURN obj + END TypeObj; + + + PROCEDURE Align (n: INTEGER); + VAR p: INTEGER; + BEGIN + p := DevCPM.ObjLen(); + DevCPM.ObjWBytes(zero, (-p) MOD n) + END Align; + + PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR); + VAR ch: SHORTCHAR; i: SHORTINT; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256))) + END + END Out2; + + PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H))); + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjWLInt(x) + END + END Out4; + + PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER); + VAR link: DevCPT.LinkList; + BEGIN + link := OffsetLink(obj, offs); + IF link # NIL THEN + Out4(typ * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := -(DevCPM.ObjLen() - headSize - 4) + ELSE Out4(0) + END + END OutReference; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form = Pointer THEN + IF ip & (typ.sysflag = interface) + OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface) + OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num) + ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, ip, num); + IF num # i THEN i := 1; + WHILE i < n DO + INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i) + END + END + END + END + END FindPtrs; + + + PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR); + BEGIN + DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name) + END OutRefName; + + PROCEDURE OutRefs* (obj: DevCPT.Object); + VAR f: BYTE; + BEGIN + IF outRef & (obj # NIL) THEN + OutRefs(obj.left); + IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN + f := obj.typ.form; + IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) + OR outURef & (obj.typ.comp # DynArr) + OR outAllRef & ~obj.typ.untagged + OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN + IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END; + IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr))) + ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec))) + ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16))) + ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64))) + ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid))) + ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult))) + ELSIF f = Pointer THEN + IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface))) + ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + END + ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN + DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1))) + ELSE DevCPM.ObjW(SHORT(CHR(f))) + END; + IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END; + OutName(obj.name^) + END + END ; + OutRefs(obj.right) + END + END OutRefs; + + PROCEDURE OutSourceRef* (pos: INTEGER); + BEGIN + IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN + WHILE pc > codePos + 250 DO + DevCPM.ObjW(SHORT(CHR(250))); + INC(codePos, 250); + DevCPM.ObjWNum(0) + END; + DevCPM.ObjW(SHORT(CHR(pc - codePos))); + codePos := pc; + DevCPM.ObjWNum(pos - srcPos); + srcPos := pos + END + END OutSourceRef; + + + PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER); + BEGIN + WHILE link # NIL DO + ASSERT(link.linkadr # 0); + DevCPM.ObjWNum(link.linkadr); + DevCPM.ObjWNum(adr + link.offset); + link := link.next + END + END OutPLink; + + PROCEDURE OutLink (link: DevCPT.LinkList); + BEGIN + OutPLink(link, 0); DevCPM.ObjW(0X) + END OutLink; + + PROCEDURE OutNames; + VAR a, b, c: DevCPT.Object; + BEGIN + a := nameList; b := NIL; + WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END; + DevCPM.ObjW(0X); (* names[0] = 0X *) + WHILE b # NIL DO + OutName(b.name^); + b := b.nlink + END; + END OutNames; + + PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR); + + PROCEDURE Copy (n: INTEGER); + VAR x, y: INTEGER; + BEGIN + x := ORD(str[n]); y := ORD(str[n + 1]); + IF x >= ORD("a") THEN DEC(x, ORD("a") - 10) + ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10) + ELSE DEC(x, ORD("0")) + END; + IF y >= ORD("a") THEN DEC(y, ORD("a") - 10) + ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10) + ELSE DEC(y, ORD("0")) + END; + DevCPM.ObjW(SHORT(CHR(x * 16 + y))) + END Copy; + + BEGIN + IF bigEndian THEN + Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17) + ELSE + Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15) + END; + Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35) + END OutGuid; + + PROCEDURE OutConst (obj: DevCPT.Object); + TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR; + VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER; + BEGIN + a := obj.conval; b := NIL; + WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END; + WHILE b # NIL DO + IF String8 IN b.setval THEN + DevCPM.ObjWBytes(b.ext^, b.intval2); + Align(4) + ELSIF String16 IN b.setval THEN + i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0; + Align(4) + ELSIF Real32 IN b.setval THEN + r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r); + IF DevCPM.LEHost = bigEndian THEN + ch := a4[0]; a4[0] := a4[3]; a4[3] := ch; + ch := a4[1]; a4[1] := a4[2]; a4[2] := ch + END; + DevCPM.ObjWBytes(a4, 4) + ELSIF Real64 IN b.setval THEN + a8 := SYSTEM.VAL(A8, b.realval); + IF DevCPM.LEHost = bigEndian THEN + ch := a8[0]; a8[0] := a8[7]; a8[7] := ch; + ch := a8[1]; a8[1] := a8[6]; a8[6] := ch; + ch := a8[2]; a8[2] := a8[5]; a8[5] := ch; + ch := a8[3]; a8[3] := a8[4]; a8[4] := ch + END; + DevCPM.ObjWBytes(a8, 8) + ELSIF Int64 IN b.setval THEN + (* intval moved to intval2 by AllocConst *) + x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x; + IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END + ELSIF Guid IN b.setval THEN + OutGuid(b.ext^) + END; + b := b.link + END + END OutConst; + + PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN); + BEGIN + IF typ = NIL THEN Out4(0) + ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr) + ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec) + ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr) + ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid) + ELSIF typ = DevCPT.restyp THEN Out4(mResult) + ELSE + CASE typ.form OF + | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0) + | Bool, Char8: Out4(typ.form - 1) + | Int8..Set: Out4(typ.form) + | Char16: Out4(mChar16) + | Int64: Out4(mInt64) + | ProcTyp: OutReference(TypeObj(typ), 0, absolute) + | Pointer: + IF typ.sysflag = interface THEN Out4(mInterface) + ELSIF typ.untagged THEN Out4(mSysPtr) + ELSE OutReference(TypeObj(typ), 0, absolute) + END + | Comp: + IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute) + ELSE Out4(0) + END + END + END + END OutStruct; + + PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER; + VAR n: INTEGER; + BEGIN + n := 0; + IF obj.name # DevCPT.null THEN + IF obj.num = 0 THEN + obj.num := namex; + WHILE obj.name[n] # 0X DO INC(n) END; + INC(namex, n + 1); + obj.nlink := nameList; nameList := obj + END; + n := obj.num; + END; + RETURN n + END NameIdx; + + PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER); + VAR p: DevCPT.Object; n, m: INTEGER; + BEGIN + pos := DevCPM.ObjLen() - headSize; + OutStruct(retTyp, TRUE); + p := par; n := 0; + WHILE p # NIL DO INC(n); p := p.link END; + Out4(n); p := par; + WHILE p # NIL DO + IF p.mode # VarPar THEN m := mValue + ELSIF p.vis = inPar THEN m := mInPar + ELSIF p.vis = outPar THEN m := mOutPar + ELSE m := mVarPar + END; + Out4(NameIdx(p) * 256 + m); + OutStruct(p.typ, TRUE); + p := p.link + END + END OutSignature; + + PROCEDURE PrepObject (obj: DevCPT.Object); + BEGIN + IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *) + OutSignature(obj.link, obj.typ, obj.conval.intval) + END + END PrepObject; + + PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object); + VAR vis: INTEGER; + BEGIN + Out4(fprint); + Out4(offs); + IF obj.vis = internal THEN vis := mInternal + ELSIF obj.vis = externalR THEN vis := mReadonly + ELSIF obj.vis = external THEN vis := mExported + END; + Out4(mode + vis * 16 + NameIdx(obj) * 256); + IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *) + ELSE OutStruct(typ, mode = mField) + END + END OutObject; + + PROCEDURE PrepDesc (desc: DevCPT.Struct); + VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct; + BEGIN + IF desc.comp = Record THEN (* write field list *) + desc.strobj.adr := DevCPM.ObjLen() - headSize; + n := 0; fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN INC(n) END; + fld := fld.link + END; + Out4(n); fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN + OutObject(mField, 0, fld.adr, fld.typ, fld) + END; + fld := fld.link + END + ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *) + OutSignature(desc.link, desc.BaseTyp, desc.n) + END; + (* assert name and base type are included *) + IF desc.untagged THEN n := NameIdx(untgd) + ELSE n := NameIdx(desc.strobj) + END; + IF desc.form # ProcTyp THEN b := desc.BaseTyp; + IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp}) + & (b.sysflag # interface) & (b # DevCPT.guidtyp) + & (~b.untagged OR outURef & (b.form = Comp)) THEN + l := OffsetLink(TypeObj(b), 0) + END + END + END PrepDesc; + + PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END; + obj := NumMeth(root.left, num); + IF obj = NIL THEN obj := NumMeth(root.right, num) END; + RETURN obj + END NumMeth; + + PROCEDURE OutDesc (desc: DevCPT.Struct); + VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE; + name: DevCPT.Name; + BEGIN + ASSERT(~desc.untagged); + IF desc.comp = Record THEN + xb := desc; flddir := desc.strobj.adr; + REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged; + Out4(-1); i := desc.n; + WHILE i > 0 DO DEC(i); t := desc; + REPEAT + m := NumMeth(t.link, i); t := t.BaseTyp + UNTIL (m # NIL) OR (t = xb); + IF m # NIL THEN + IF absAttr IN m.conval.setval THEN Out4(0) + ELSE OutReference(m, 0, absolute) + END + ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *) + ELSE OutReference(xb.strobj, -4 - 4 * i, copy) + END + END; + desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *) + Out4(desc.size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + IF desc.attribute = extAttr THEN attr := 1 + ELSIF desc.attribute = limAttr THEN attr := 2 + ELSIF desc.attribute = absAttr THEN attr := 3 + ELSE attr := 0 + END; + Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0; + WHILE i <= desc.extlev DO + t := desc; + WHILE t.extlev > i DO t := t.BaseTyp END; + IF t.sysflag = interface THEN Out4(0) + ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute) + ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute) + ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute) + ELSE OutReference(xb.strobj, 12 + 4 * i, copy) + END; + INC(i) + END; + WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END; + OutReference(Meta, flddir, absolute); (* ref to field list *) + nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr); + Out4(-(4 * nofptr + 4)); + nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr); + Out4(-1) + ELSE + desc.strobj.adr := DevCPM.ObjLen() - headSize; + lev := 0; size := 0; + IF desc.comp = Array THEN + size := desc.n; form := mArray + ELSIF desc.comp = DynArr THEN + form := mArray; lev := SHORT(SHORT(desc.n + 1)) + ELSIF desc.form = Pointer THEN + form := mPointer + ELSE ASSERT(desc.form = ProcTyp); + DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp; + END; + Out4(size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + Out4(form + lev * 16 + NameIdx(m) * 256); + IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE) + ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *) + END + END + END OutDesc; + + PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER); + VAR i: INTEGER; t: Dates.Time; d: Dates.Date; + BEGIN + Out4(0); (* link *) + Out4(ORD(options)); (* opts *) + Out4(0); (* refcnt *) + Dates.GetDate(d); Dates.GetTime(t); (* compile time *) + Out2(d.year); Out2(d.month); Out2(d.day); + Out2(t.hour); Out2(t.minute); Out2(t.second); + Out4(0); Out4(0); Out4(0); (* load time *) + Out4(0); (* ext *) + IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *) + ELSE Out4(0) + END; + Out4(imports); (* nofimps *) + Out4(nofptr); (* nofptrs *) + Out4(pc); (* csize *) + Out4(dsize); (* dsize *) + Out4(refSize); (* rsize *) + OutReference(Code, 0, absolute); (* code *) + OutReference(Data, 0, absolute); (* data *) + OutReference(Meta, 0, absolute); (* refs *) + IF procVarIndirect THEN + OutReference(Proc, 0, absolute); (* procBase *) + ELSE + OutReference(Code, 0, absolute); (* procBase *) + END; + OutReference(Data, 0, absolute); (* varBase *) + OutReference(Meta, namePos, absolute); (* names *) + OutReference(Meta, ptrPos, absolute); (* ptrs *) + OutReference(Meta, impPos, absolute); (* imports *) + OutReference(Meta, expPos, absolute); (* export *) + i := 0; (* name *) + WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END; + DevCPM.ObjW(0X); + Align(4) + END OutModDesc; + + PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *) + BEGIN + IF obj # NIL THEN + OutProcTable(obj.left); + IF obj.mode IN {XProc, IProc} THEN + Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0); + END; + OutProcTable(obj.right); + END; + END OutProcTable; + + PROCEDURE PrepExport (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + PrepExport(obj.left); + IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN + PrepObject(obj) + END; + PrepExport(obj.right) + END + END PrepExport; + + PROCEDURE OutExport (obj: DevCPT.Object); + VAR num: INTEGER; + BEGIN + IF obj # NIL THEN + OutExport(obj.left); + IF (obj.history # removed) & ((obj.vis # internal) OR + (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN + DevCPT.FPrintObj(obj); + IF obj.mode IN {LProc, XProc, IProc} THEN + IF procVarIndirect THEN + ASSERT(obj.nlink = NIL); + num := obj.num; obj.num := 0; + OutObject(mProc, obj.fprint, num, NIL, obj); + obj.num := num + ELSE + OutObject(mProc, obj.fprint, obj.adr, NIL, obj) + END + ELSIF obj.mode = Var THEN + OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj) + ELSIF obj.mode = Typ THEN + OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj) + ELSE ASSERT(obj.mode IN {Con, CProc}); + OutObject(mConst, obj.fprint, 0, NIL, obj) + END + END; + OutExport(obj.right) + END + END OutExport; + + PROCEDURE OutCLinks (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + OutCLinks(obj.left); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END; + OutCLinks(obj.right) + END + END OutCLinks; + + PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER); + BEGIN + IF obj # NIL THEN + OutCPLinks(obj.left, base); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END; + OutCPLinks(obj.right, base) + END + END OutCPLinks; + + PROCEDURE OutImport (obj: DevCPT.Object); + VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER; + BEGIN + IF obj # NIL THEN + OutImport(obj.left); + IF obj.mode = Typ THEN typ := obj.typ; + IF obj.used OR + (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) & + ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN + DevCPT.FPrintStr(typ); + DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^); + IF obj.used THEN opt := 2 ELSE opt := 0 END; + IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN + DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1))); + IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END + ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt))) + END; + OutLink(obj.links) + END + ELSIF obj.used THEN + DevCPT.FPrintObj(obj); + IF obj.mode = Var THEN + DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSIF obj.mode IN {XProc, IProc} THEN + DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSE ASSERT(obj.mode IN {Con, CProc}); + DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint) + END + END; + OutImport(obj.right) + END + END OutImport; + + PROCEDURE OutUseBlock; + VAR m, obj: DevCPT.Object; i: INTEGER; + BEGIN + m := dllList; + WHILE m # NIL DO + obj := m.nlink; + WHILE obj # NIL DO + IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))) + ELSE DevCPM.ObjW(SHORT(CHR(mProc))) + END; + IF obj.entry # NIL THEN OutName(obj.entry^) + ELSE OutName(obj.name^); + END; + DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links); + obj := obj.nlink + END; + DevCPM.ObjW(0X); m := m.link + END; + i := 1; + WHILE i < DevCPT.nofGmod DO + obj := DevCPT.GlbMod[i]; + IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END; + INC(i) + END; + END OutUseBlock; + + PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String); + VAR name: DevCPT.String; dll: DevCPT.Object; + BEGIN + IF obj # NIL THEN + CollectDll(obj.left, mod); + IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN + IF obj.library # NIL THEN name := obj.library + ELSE name := mod + END; + dll := dllList; + WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END; + IF dll = NIL THEN + NEW(dll); dll.library := name; INC(imports); + IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END; + dllLast := dll; dll.left := dll; + END; + dll.left.nlink := obj; dll.left := obj + END; + CollectDll(obj.right, mod) + END + END CollectDll; + + PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER); + BEGIN + IF obj # NIL THEN + EnumXProc(obj.left, num); + IF obj.mode IN {XProc, IProc} THEN + obj.num := num; INC(num, 8); + END; + EnumXProc(obj.right, num) + END; + END EnumXProc; + + PROCEDURE OutHeader*; + VAR i: INTEGER; m: DevCPT.Object; + BEGIN + DevCPM.ObjWLInt(processor); (* processor type *) + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *) + imports := 0; i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library # NIL THEN (* dll import *) + CollectDll(m.right, m.library); + ELSE INC(imports) (* module import *) + END; + INC(i) + END; + DevCPM.ObjWNum(imports); (* num of import *) + OutName(DevCPT.SelfName); + m := dllList; + WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END; + i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library = NIL THEN OutName(m.name^) END; + INC(i) + END; + Align(16); headSize := DevCPM.ObjLen(); + IF procVarIndirect THEN + i := 0; EnumXProc(DevCPT.topScope.right, i) + END + END OutHeader; + + PROCEDURE OutCode*; + VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos, + con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER; + m, obj, dlist: DevCPT.Object; + BEGIN + (* Ref *) + DevCPM.ObjW(0X); (* end mark *) + refSize := DevCPM.ObjLen() - headSize; + (* Export *) + Align(4); + IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *) + Align(8); expPos := DevCPM.ObjLen(); + Out4(0); + OutExport(DevCPT.topScope.right); (* export objects *) + i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i); + (* Pointers *) + ptrPos := DevCPM.ObjLen(); + obj := DevCPT.topScope.scope; nofptrs := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END; + obj := DevCPT.topScope.scope; i := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END; + IF i > 0 THEN Out4(-1); INCL(options, iptrs) END; + (* Prepare Type Descriptors *) + dlist := NIL; + WHILE descList # NIL DO + obj := descList; descList := descList.link; + PrepDesc(obj.typ); + obj.link := dlist; dlist := obj + END; + (* Import List *) + impPos := DevCPM.ObjLen(); i := 0; + WHILE i < imports DO Out4(0); INC(i) END; + (* Names *) + namePos := DevCPM.ObjLen(); OutNames; + (* Const *) + Align(4); con8Pos := DevCPM.ObjLen(); + OutConst(Const8); con16Pos := DevCPM.ObjLen(); + ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8); + OutConst(Const16); con32Pos := DevCPM.ObjLen(); + ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16); + OutConst(Const32); con64Pos := DevCPM.ObjLen(); + ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32); + IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END; + OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64); + (* Module Descriptor *) + Align(16); modPos := DevCPM.ObjLen(); + OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize); + (* Procedure Table *) + procPos := DevCPM.ObjLen(); + OutProcTable(DevCPT.topScope.right); + Out4(0); Out4(0); (* at least one entry in ProcTable *) + Out4(0); (* sentinel *) + (* Type Descriptors *) + obj := dlist; + WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END; + (* Code *) + codePos := DevCPM.ObjLen(); WriteCode; + WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END; + (* Fixups *) + OutLink(KNewRec.links); OutLink(KNewArr.links); + (* metalink *) + OutPLink(Const8.links, con8Pos - headSize); + OutPLink(Const16.links, con16Pos - headSize); + OutPLink(Const32.links, con32Pos - headSize); + OutPLink(Const64.links, con64Pos - headSize); + OutLink(Meta.links); + (* desclink *) + obj := dlist; i := modPos - headSize; + WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END; + IF procVarIndirect THEN + OutPLink(Proc.links, procPos - modPos); + OutCPLinks(DevCPT.topScope.right, procPos - modPos) + END; + OutLink(Mod.links); + (* codelink *) + IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END; + OutPLink(CaseLinks, 0); OutLink(Code.links); + (* datalink *) + OutLink(Data.links); + (* Use *) + OutUseBlock; + (* Header Fixups *) + DevCPM.ObjSet(8); + DevCPM.ObjWLInt(headSize); + DevCPM.ObjWLInt(modPos - headSize); + DevCPM.ObjWLInt(codePos - modPos); + DevCPM.ObjWLInt(pc); + DevCPM.ObjWLInt(dsize); + IF namex > MaxNameTab THEN DevCPM.err(242) END; + IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END + END OutCode; + + PROCEDURE Init* (proc: INTEGER; opt: SET); + CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14; + BEGIN + processor := proc; + bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt; + outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt; + outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options); + outSrc := srcpos IN opt; + pc := 0; actIdx := CodeLength; blkIdx := 0; + idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1; + options := opt * {0..15}; CodeOvF := FALSE; + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + codePos := 0; srcPos := 0; + NEW(untgd); untgd.name := DevCPT.NewName("!"); + closeLbl := 0 + END Init; + + PROCEDURE Close*; + BEGIN + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END; + actual := NIL; untgd := NIL; + END Close; + +BEGIN + NEW(KNewRec); KNewRec.mnolev := -128; + NEW(KNewArr); KNewArr.mnolev := -128; + NEW(Const8); Const8.mode := Con; Const8.mnolev := 0; + NEW(Const16); Const16.mode := Con; Const16.mnolev := 0; + NEW(Const32); Const32.mode := Con; Const32.mnolev := 0; + NEW(Const64); Const64.mode := Con; Const64.mnolev := 0; + NEW(Code); Code.mode := Con; Code.mnolev := 0; + NEW(Data); Data.mode := Con; Data.mnolev := 0; + NEW(Mod); Mod.mode := Con; Mod.mnolev := 0; + NEW(Proc); Proc.mode := Con; Proc.mnolev := 0; + NEW(Meta); Meta.mode := Con; Mod.mnolev := 0; +END DevCPE. diff --git a/Trurl-based/Dev/Mod/CPH.txt b/Trurl-based/Dev/Mod/CPH.txt new file mode 100644 index 0000000..c55a9e6 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPH.txt @@ -0,0 +1,291 @@ +MODULE DevCPH; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPH.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPT; + + CONST + (* UseCalls options *) + longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3; + realMop* = 8; realDop* = 9; realConv* = 10; + intMulDiv* = 11; + force = 16; hide = 17; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + + + PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR); + VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN; + BEGIN + IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real" + ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal" + ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long" + ELSE mod := "Int" + END; + moda := mod + "%"; + DevCPT.Find(moda, mobj); + IF mobj = NIL THEN + DevCPT.Import(moda, mod, done); + IF done THEN DevCPT.Find(moda, mobj) END + END; + nm := name$; DevCPT.FindImport(nm, mobj, obj); + n.class := Ncall; n.subcl := 0; n.obj := obj.link; + n.left.link := n.right; n.right := n.left; + n.left := DevCPT.NewNode(Nproc); + n.left.obj := obj; n.left.typ := obj.typ; + ASSERT(n.typ.form = obj.typ.form) + END UseThisCall; + + PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct); + VAR new: DevCPT.Node; r: REAL; + BEGIN + IF n.class = Nconst THEN + ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp)); + r := n.conval.realval + n.conval.intval; + IF r = n.conval.realval + n.conval.intval THEN + n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL + END + END; + IF (n.typ # typ) + & ((n.class # Nmop) OR (n.subcl # conv) + OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN + new := DevCPT.NewNode(0); new^ := n^; + n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL + END; + n.typ := typ + END Convert; + + PROCEDURE UseCallForComp (n: DevCPT.Node); + VAR new: DevCPT.Node; + BEGIN + new := DevCPT.NewNode(0); + new.left := n.left; new.right := n.right; + new.typ := DevCPT.int32typ; + UseThisCall(new, "Comp"); + n.left := new; + n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst(); + n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ; + END UseCallForComp; + + PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET); + VAR f, g: INTEGER; typ: DevCPT.Struct; + BEGIN + typ := n.typ; f := typ.form; g := n.left.typ.form; + IF realConv IN opts THEN + IF f IN realSet THEN + IF g = Real32 THEN UseThisCall(n, "Long") + ELSIF g = Real64 THEN UseThisCall(n, "Short") + ELSIF g = Int64 THEN UseThisCall(n, "LFloat") + ELSIF g = Int32 THEN UseThisCall(n, "Float") + ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float") + END + ELSIF g IN realSet THEN + IF f = Int64 THEN UseThisCall(n, "LFloor") + ELSIF f = Int32 THEN UseThisCall(n, "Floor") + ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ) + END + END + END; + IF longConv IN opts THEN + IF f = Int64 THEN + IF g = Int32 THEN UseThisCall(n, "Long") + ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong") + END + ELSIF g = Int64 THEN + IF f = Int32 THEN UseThisCall(n, "Short") + ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ) + END + END + END + END UseCallForConv; + + PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET); + BEGIN + CASE n.subcl OF + | minus: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Neg") + END + | abs: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Abs") + END + | odd: + IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END + | conv: + UseCallForConv(n, opts) + ELSE + END + END UseCallForMop; + + PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET); + BEGIN + IF (realDop IN opts) & (n.left.typ.form IN realSet) + OR (longDop IN opts) & (n.left.typ.form = Int64) + OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN + CASE n.subcl OF + | times: UseThisCall(n, "Mul") + | slash: UseThisCall(n, "Div") + | div: UseThisCall(n, "Div") + | mod: UseThisCall(n, "Mod") + | plus: UseThisCall(n, "Add") + | minus: UseThisCall(n, "Sub") + | ash: UseThisCall(n, "Ash") + | min: UseThisCall(n, "Min") + | max: UseThisCall(n, "Max") + | eql..geq: UseCallForComp(n) + ELSE + END + END + END UseCallForDop; + + PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET); + VAR f, g: INTEGER; + BEGIN + f := n.typ.form; g := typ.form; + IF f # g THEN + IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet)) + OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN + Convert(n, typ); + UseCallForConv(n, opts) + END + END + END UseCallForMove; + + PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET); + BEGIN + IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END + END UseCallForAssign; + + PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET); + BEGIN + IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END + END UseCallForReturn; + + PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET); + BEGIN + WHILE n # NIL DO + UseCallForMove(n, fp.typ, opts); + n := n.link; fp := fp.link + END + END UseCallForParam; + + PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + UseCalls(n.left, opts); UseCallForMop(n, opts) + | Ndop: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts) + | Ncase: + UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts) + | Nassign: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts) + | Ncall: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts) + | Nreturn: + UseCalls(n.left, opts); UseCallForReturn(n, opts) + | Ncasedo: + UseCalls(n.right, opts) + | Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard: + UseCalls(n.left, opts) + | Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseCalls(n.left, opts); UseCalls(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END UseCalls; + + + PROCEDURE UseReals* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN + UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp + ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide}) + ELSE UseReals(n.left, opts - {force, hide}) + END + | Ndop: + IF (longDop IN opts) & (n.left.typ.form = Int64) THEN + UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force}); + IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END + ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + END + | Ncase: + UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide}); + UseReals(n.right.right, opts - {force, hide}) + | Ncasedo: + UseReals(n.right, opts - {force, hide}) + | Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard: + UseReals(n.left, opts - {force, hide}) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + IF force IN opts THEN Convert(n, DevCPT.intrealtyp) + ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ) + END; + n := n.link + END + END UseReals; + +END DevCPH. + + + + + PROCEDURE Traverse (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Ncase: + Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts) + | Ncasedo: + Traverse(n.right, opts) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + Traverse(n.left, opts) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + Traverse(n.left, opts); Traverse(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END Traverse; + diff --git a/Trurl-based/Dev/Mod/CPL486.txt b/Trurl-based/Dev/Mod/CPL486.txt new file mode 100644 index 0000000..a0ae315 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPL486.txt @@ -0,0 +1,1057 @@ +MODULE DevCPL486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPL486.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPM, DevCPT, DevCPE; + + TYPE + Item* = RECORD + mode*, tmode*, form*: BYTE; + offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *) + typ*: DevCPT.Struct; + obj*: DevCPT.Object + END ; + +(* Items: + + mode | offset index scale reg obj +------------------------------------------------ + 1 Var | adr xreg scale obj (ea = FP + adr + xreg * scale) + 2 VarPar| off xreg scale obj (ea = [FP + obj.adr] + off + xreg * scale) + 3 Con | val (val2) NIL + Con | off obj (val = adr(obj) + off) + Con | id NIL (for predefined reals) + 6 LProc | obj + 7 XProc | obj + 9 CProc | obj +10 IProc | obj +13 TProc | mthno 0/1 obj (0 = normal / 1 = super call) +14 Ind | off xreg scale Reg (ea = Reg + off + xreg * scale) +15 Abs | adr xreg scale NIL (ea = adr + xreg * scale) + Abs | off xreg scale obj (ea = adr(obj) + off + xreg * scale) + Abs | off len 0 obj (for constant strings and reals) +16 Stk | (ea = ESP) +17 Cond | CC +18 Reg | (Reg2) Reg +19 DInd | off xreg scale Reg (ea = [Reg + off + xreg * scale]) + + tmode | record tag array desc +------------------------------------- + VarPar | [FP + obj.adr + 4] [FP + obj.adr] + Ind | [Reg - 4] [Reg + 8] + Con | Adr(typ.strobj) + +*) + + CONST + processor* = 10; (* for i386 *) + NewLbl* = 0; + + TYPE + Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *) + + VAR + level*: BYTE; + one*: DevCPT.Const; + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 (must not overlap item basemodes, > 13) *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + + VAR + Size: ARRAY 32 OF INTEGER; (* Size[typ.form] == +/- typ.size *) + a1, a2: Item; + + + PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE); + BEGIN + ASSERT((reg >= 0) & (reg < 8)); + x.mode := Reg; x.reg := reg; x.form := form + END MakeReg; + + PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE); + BEGIN + x.mode := Con; x.offset := val; x.form := form; x.obj := NIL; + END MakeConst; + + PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE); + VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER; + BEGIN + IF form IN {Real32, Real64} THEN + r := con.realval; + IF ABS(r) <= MAX(SHORTREAL) THEN + short := SHORT(r); + IF short = r THEN form := Real32 (* a shortreal can represent the exact value *) + ELSE form := Real64 (* use a real *) + END + ELSE form := Real64 (* use a real *) + END + ELSIF form IN {String8, String16, Guid} THEN + x.index := con.intval2 (* string length *) + END; + DevCPE.AllocConst(con, form, x.obj, x.offset); + x.form := form; x.mode := Abs; x.scale := 0 + END AllocConst; + + (*******************************************************) + + PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *) + BEGIN + END BegStat; + + PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *) + BEGIN + END EndStat; + + (*******************************************************) + + PROCEDURE SetLabel* (VAR L: Label); + VAR link, typ, disp, x: INTEGER; c: SHORTCHAR; + BEGIN + ASSERT(L <= 0); link := -L; + WHILE link # 0 DO + typ := link DIV 1000000H; link := link MOD 1000000H; + IF typ = short THEN + disp := DevCPE.pc - link - 1; ASSERT(disp < 128); + DevCPE.PutByte(link, disp); link := 0 + ELSIF typ = relative THEN + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x + ELSE + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x + END + END; + L := DevCPE.pc; + a1.mode := 0; a2.mode := 0 + END SetLabel; + + + (*******************************************************) + + PROCEDURE GenWord (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256) + END GenWord; + + PROCEDURE GenDbl (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H) + END GenDbl; + + PROCEDURE CaseEntry* (tab, from, to: INTEGER); + VAR a, e: INTEGER; + BEGIN + a := tab + 4 * from; e := tab + 4 * to; + WHILE a <= e DO + DevCPE.PutByte(a, DevCPE.pc); + DevCPE.PutByte(a + 1, DevCPE.pc DIV 256); + DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536); + INC(a, 4) + END; + a1.mode := 0; a2.mode := 0 + END CaseEntry; + + PROCEDURE GenLinked (VAR x: Item; type: BYTE); + VAR link: DevCPT.LinkList; + BEGIN + IF x.obj = NIL THEN GenDbl(x.offset) + ELSE + link := DevCPE.OffsetLink(x.obj, x.offset); + IF link # NIL THEN + GenDbl(type * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := DevCPE.pc - 4 + ELSE GenDbl(0) + END + END + END GenLinked; + + PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER); + BEGIN + IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1 + ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1 + ELSE w := 0 + END + END CheckSize; + + PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER); + BEGIN + IF form = Real32 THEN mf := 0 + ELSIF form = Real64 THEN mf := 4 + ELSIF form = Int32 THEN mf := 2 + ELSE ASSERT(form = Int16); mf := 6 + END + END CheckForm; + + PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER); + BEGIN + IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2 + ELSE s := 0 + END + END CheckConst; + + PROCEDURE GenConst (VAR x: Item; short: BOOLEAN); + BEGIN + IF x.obj # NIL THEN GenLinked(x, absolute) + ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset) + ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset) + ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset) + ELSE GenDbl(x.offset) + END + END GenConst; + + PROCEDURE GenCExt (code: INTEGER; VAR x: Item); + VAR disp, mod, base, scale: INTEGER; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs, Stk}); + ASSERT((code MOD 8 = 0) & (code < 64)); + disp := x.offset; base := x.reg; scale := x.scale; + IF x.mode = Reg THEN mod := 0C0H; scale := 0 + ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0 + ELSIF x.mode = Abs THEN + IF scale = 1 THEN base := x.index; mod := 80H; scale := 0 + ELSE base := BP; mod := 0 + END + ELSIF (disp = 0) & (base # BP) THEN mod := 0 + ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H + ELSE mod := 80H + END; + IF scale # 0 THEN + DevCPE.GenByte(mod + code + 4); base := base + x.index * 8; + IF scale = 8 THEN DevCPE.GenByte(0C0H + base); + ELSIF scale = 4 THEN DevCPE.GenByte(80H + base); + ELSIF scale = 2 THEN DevCPE.GenByte(40H + base); + ELSE ASSERT(scale = 1); DevCPE.GenByte(base); + END; + ELSE + DevCPE.GenByte(mod + code + base); + IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END + END; + IF x.mode = Abs THEN GenLinked(x, absolute) + ELSIF mod = 80H THEN GenDbl(disp) + ELSIF mod = 40H THEN DevCPE.GenByte(disp) + END + END GenCExt; + + PROCEDURE GenDExt (VAR r, x: Item); + BEGIN + ASSERT(r.mode = Reg); + GenCExt(r.reg * 8, x) + END GenDExt; + + (*******************************************************) + + PROCEDURE GenMove* (VAR from, to: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[from.form] = Size[to.form]); + IF to.mode = Reg THEN + IF from.mode = Con THEN + IF to.reg = AX THEN + + IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0 + END; + CheckSize(from.form, w); + IF (from.offset = 0) & (from.obj = NIL) THEN + DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *) + ELSE + DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE) + END; + ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN + + IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) + OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0; + CheckSize(from.form, w); + DevCPE.GenByte(0A0H + w); GenLinked(from, absolute); + ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN + IF to.reg = AX THEN + IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN + + IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form) + OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from + ELSE a1.mode := 0 + END; + a2.mode := 0 + END; + CheckSize(from.form, w); + DevCPE.GenByte(8AH + w); GenDExt(to, from) + END + ELSE + CheckSize(from.form, w); + IF from.mode = Con THEN + DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE); + a1.mode := 0; a2.mode := 0 + ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN + DevCPE.GenByte(0A2H + w); GenLinked(to, absolute); + a2 := to + ELSE + DevCPE.GenByte(88H + w); GenDExt(from, to); + IF from.reg = AX THEN + IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END + ELSE a1.mode := 0; a2.mode := 0 + END + END + END + END GenMove; + + PROCEDURE GenExtMove* (VAR from, to: Item); + VAR w, op: INTEGER; + BEGIN + ASSERT(from.mode # Con); + IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *) + ELSE op := 0BEH (* MOVSX *) + END; + IF from.form IN {Int16, Char16} THEN INC(op) END; + DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from); + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenExtMove; + + PROCEDURE GenSignExt* (VAR from, to: Item); + BEGIN + ASSERT(to.mode = Reg); + IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN + DevCPE.GenByte(99H) (* cdq *) + ELSE + GenMove(from, to); (* mov to, from *) + DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31) (* sar to, 31 *) + END + END GenSignExt; + + PROCEDURE GenLoadAdr* (VAR from, to: Item); + BEGIN + ASSERT(to.form IN {Int32, Pointer, ProcTyp}); + IF (from.mode = Abs) & (from.scale = 0) THEN + DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute) + ELSIF from.mode = Stk THEN + DevCPE.GenByte(89H); GenCExt(SP * 8, to) + ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN + DevCPE.GenByte(8DH); GenDExt(to, from) + ELSIF from.reg # to.reg THEN + DevCPE.GenByte(89H); GenCExt(from.reg * 8, to) + ELSE RETURN + END; + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenLoadAdr; + + PROCEDURE GenPush* (VAR src: Item); + VAR s: INTEGER; + BEGIN + IF src.mode = Con THEN + ASSERT(src.form >= Int32); + CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE) + ELSIF src.mode = Reg THEN + ASSERT((src.form >= Int16) OR (src.reg < 4)); + DevCPE.GenByte(50H + src.reg) + ELSE + ASSERT(src.form >= Int32); + DevCPE.GenByte(0FFH); GenCExt(30H, src) + END + END GenPush; + + PROCEDURE GenPop* (VAR dst: Item); + BEGIN + IF dst.mode = Reg THEN + ASSERT((dst.form >= Int16) OR (dst.reg < 4)); + DevCPE.GenByte(58H + dst.reg); + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + ELSE + DevCPE.GenByte(08FH); GenCExt(0, dst) + END + END GenPop; + + PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item); + VAR w, s: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + CheckConst(src, s); + IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN + DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE) + ELSE + DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE) + END + END GenConOp; + + PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + IF dst.mode = Reg THEN + DevCPE.GenByte(op + 2 + w); GenDExt(dst, src) + ELSE + DevCPE.GenByte(op + w); GenDExt(src, dst) + END + END GenDirOp; + + PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(0, src, dst) + ELSE RETURN + END + ELSE + GenConOp(0, src, dst) + END + ELSE + GenDirOp(0, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAdd; + + PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 0 ELSE op := 10H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAddC; + + PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(28H, src, dst) + ELSE RETURN + END + ELSE + GenConOp(28H, src, dst) + END + ELSE + GenDirOp(28H, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSub; + + PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 28H ELSE op := 18H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSubC; + + PROCEDURE GenComp* (VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + IF src.mode = Con THEN + IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN + CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *) + ELSE GenConOp(38H, src, dst) + END + ELSE + GenDirOp(38H, src, dst) + END + END GenComp; + + PROCEDURE GenAnd* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END + ELSE GenDirOp(20H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAnd; + + PROCEDURE GenOr* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END + ELSE GenDirOp(8H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenOr; + + PROCEDURE GenXor* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END + ELSE GenDirOp(30H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenXor; + + PROCEDURE GenTest* (VAR x, y: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[x.form] = Size[y.form]); + CheckSize(x.form, w); + IF x.mode = Con THEN + IF (x.mode = Reg) & (x.reg = AX) THEN + DevCPE.GenByte(0A8H + w); GenConst(x, FALSE) + ELSE + DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE) + END + ELSE + DevCPE.GenByte(84H + w); + IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END + END + END GenTest; + + PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst); + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNeg; + + PROCEDURE GenNot* (VAR dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNot; + + PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w, s, val, f2, f5, f9: INTEGER; + BEGIN + ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form])); + IF (src.mode = Con) & (src.offset = 1) THEN RETURN END; + IF src.form <= Int8 THEN + ASSERT(dst.reg = 0); + DevCPE.GenByte(0F6H); GenCExt(28H, src) + ELSIF src.mode = Con THEN + val := src.offset; + IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN + f2 := 0; f5 := 0; f9 := 0; + WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END; + WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END; + WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END; + IF ABS(val) <= 3 THEN + WHILE f9 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(0C0H + dst.reg * 9); + DEC(f9) + END; + WHILE f5 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(80H + dst.reg * 9); + DEC(f5) + END; + IF ABS(val) = 3 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9) + END; + IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2) + ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9) + END; + IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END; + RETURN + END + END; + CheckSize(src.form, w); CheckConst(src, s); + DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE) + ELSE + CheckSize(src.form, w); + DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenMul; + + PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN); + VAR w, rem: INTEGER; + BEGIN + ASSERT(src.mode = Reg); + IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *) + ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *) + ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *) + END; + CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *) + IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END; + IF pos THEN (* src > 0 *) + CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + IF mod THEN + DevCPE.GenByte(79H); DevCPE.GenByte(2); (* jns end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); DevCPE.GenByte(1); (* jns end *) + DevCPE.GenByte(48H); (* dec eax *) + END + ELSE + CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + IF mod THEN + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(4); (* je end *) + DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(1); (* je end *) + DevCPE.GenByte(48H); (* dec eax *) + END +(* + CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *) + IF mod THEN + DevCPE.GenByte(72H); DevCPE.GenByte(4); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(2); (* jg end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(72H); DevCPE.GenByte(3); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(1); (* jg end *) + DevCPE.GenByte(48H); (* dec eax *) + END +*) + END; + a1.mode := 0; a2.mode := 0 + END GenDiv; + + PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); + IF cnt.mode = Con THEN + ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL); + IF cnt.offset = 1 THEN + IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *) + DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *) + ELSE + DevCPE.GenByte(0D0H + w); GenCExt(op, dst) + END + ELSIF cnt.offset > 1 THEN + DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset) + END + ELSE + ASSERT((cnt.mode = Reg) & (cnt.reg = CX)); + DevCPE.GenByte(0D2H + w); GenCExt(op, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenShiftOp; + + PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item); + BEGIN + DevCPE.GenByte(0FH); + IF num.mode = Con THEN + ASSERT(num.obj = NIL); + DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset) + ELSE + ASSERT((num.mode = Reg) & (num.form = Int32)); + DevCPE.GenByte(83H + op); GenDExt(num, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenBitOp; + + PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item); + BEGIN + ASSERT((dst.form = Bool) & (cc >= 0)); + DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSetCC; + + PROCEDURE GenFLoad* (VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Con THEN (* predefined constants *) + DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset) + ELSIF src.form = Int64 THEN + DevCPE.GenByte(0DFH); GenCExt(28H, src) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D9H + mf); GenCExt(0, src) + END + END GenFLoad; + + PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN); + VAR mf: INTEGER; + BEGIN + IF dst.form = Int64 THEN ASSERT(pop); + DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE + CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf); + IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE GenCExt(10H, dst) + END + END; + a1.mode := 0; a2.mode := 0 + END GenFStore; + + PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Reg THEN + DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D8H + mf); GenCExt(op, src) + END + END GenFDOp; + + PROCEDURE GenFMOp* (op: INTEGER); + BEGIN + DevCPE.GenByte(0D8H + op DIV 256); + DevCPE.GenByte(op MOD 256); + IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END (* FSTSW AX *) + END GenFMOp; + + PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN); + BEGIN + IF cc # ccNever THEN + IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN + IF cc = ccAlways THEN DevCPE.GenByte(0EBH) + ELSE DevCPE.GenByte(70H + cc) + END; + IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1) + ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0) + END + ELSE + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + IF L > 0 THEN GenDbl(L - DevCPE.pc - 4) + ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H) + END + END + END + END GenJump; + + PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item); + BEGIN + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + dst.offset := 0; GenLinked(dst, relative) + END GenExtJump; + + PROCEDURE GenIndJump* (VAR dst: Item); + BEGIN + DevCPE.GenByte(0FFH); GenCExt(20H, dst) + END GenIndJump; + + PROCEDURE GenCaseJump* (VAR src: Item); + VAR link: DevCPT.LinkList; tab: INTEGER; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + END GenCaseJump; +(* + PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT); + VAR link: DevCPT.LinkList; else, last: LONGINT; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + else := tab + num * 4; last := else - 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := CaseLinks; CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END; + GenDbl(tableend * 1000000H + else) + END GenCaseJump; +*) + PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN); + VAR typ: INTEGER; + BEGIN + IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END; + IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END + END GenCaseEntry; + + PROCEDURE GenCall* (VAR dst: Item); + BEGIN + IF dst.mode IN {LProc, XProc, IProc} THEN + DevCPE.GenByte(0E8H); + IF dst.obj.mnolev >= 0 THEN (* local *) + IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4) + ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H) + END + ELSE (* imported *) + dst.offset := 0; GenLinked(dst, relative) + END + ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst) + END; + a1.mode := 0; a2.mode := 0 + END GenCall; + + PROCEDURE GenAssert* (cc, no: INTEGER); + BEGIN + IF cc # ccAlways THEN + IF cc >= 0 THEN + DevCPE.GenByte(70H + cc); (* jcc end *) + IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END + END; + IF no < 0 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no) + ELSE + DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no) + END + END + END GenAssert; + + PROCEDURE GenReturn* (val: INTEGER); + BEGIN + IF val = 0 THEN DevCPE.GenByte(0C3H) + ELSE DevCPE.GenByte(0C2H); GenWord(val) + END; + a1.mode := 0; a2.mode := 0 + END GenReturn; + + PROCEDURE LoadStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *) + END LoadStr; + + PROCEDURE StoreStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *) + END StoreStr; + + PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF rep THEN DevCPE.GenByte(0F2H) END; + IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *) + END ScanStr; + + PROCEDURE TestNull (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *) + ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *) + END + END TestNull; + + PROCEDURE GenBlockMove* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *); + IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *) + END + END GenBlockMove; + + PROCEDURE GenBlockStore* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *); + IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *) + END + END GenBlockStore; + + PROCEDURE GenBlockComp* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + ASSERT(len >= 0); + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *) + END GenBlockComp; + + PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER); + (* + len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X + *) + VAR loop, end: Label; + BEGIN + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + (* len >= 0: len IN ECX *) + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *) + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + IF len < 0 THEN (* no limit *) + StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE); + IF excl THEN (* dec edi *) + DevCPE.GenByte(4FH); + IF dsize # 1 THEN DevCPE.GenByte(4FH) END + END; + ELSE (* cx limit *) + IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize) + ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE) + END; + DevCPE.GenByte(49H); (* dec ecx *) + GenJump(ccNE, loop, TRUE); + GenAssert(ccNever, copyTrap); (* trap *) + SetLabel(end) + END; + a1.mode := 0; a2.mode := 0 + END GenStringMove; + + PROCEDURE GenStringComp* (wsize, dsize: INTEGER); + (* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *) + VAR loop, end: Label; + BEGIN + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END; + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE); + IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *) + TestNull(wsize); GenJump(ccNE, loop, TRUE); + SetLabel(end); + a1.mode := 0; a2.mode := 0 + END GenStringComp; + + PROCEDURE GenStringLength* (wsize, len: INTEGER); (* len = 0: len in ECX, len = -1: len undefined *) + BEGIN + DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) + IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + ScanStr(wsize, TRUE); + a1.mode := 0; a2.mode := 0 + END GenStringLength; + + PROCEDURE GenStrStore* (size: INTEGER); + VAR w: INTEGER; + BEGIN + IF size # 0 THEN + IF size MOD 4 = 0 THEN w := 1; size := size DIV 4 + ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2 + ELSE w := 0 + END; + DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *) + IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END + ELSE w := 0 + END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + a1.mode := 0; a2.mode := 0 + END GenStrStore; + + PROCEDURE GenCode* (op: INTEGER); + BEGIN + DevCPE.GenByte(op); + a1.mode := 0; a2.mode := 0 + END GenCode; + + + PROCEDURE Init*(opt: SET); + BEGIN + DevCPE.Init(processor, opt); + level := 0; + NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc; + END Init; + + PROCEDURE Close*; + BEGIN + a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL; + DevCPE.Close + END Close; + +BEGIN + Size[Undef] := 0; + Size[Byte] := 1; + Size[Bool] := 1; + Size[Char8] := 1; + Size[Int8] := 1; + Size[Int16] := 2; + Size[Int32] := 4; + Size[Real32] := -4; + Size[Real64] := -8; + Size[Set] := 4; + Size[String8] := 0; + Size[NilTyp] := 4; + Size[NoTyp] := 0; + Size[Pointer] := 4; + Size[ProcTyp] := 4; + Size[Comp] := 0; + Size[Char16] := 2; + Size[Int64] := 8; + Size[String16] := 0 +END DevCPL486. diff --git a/Trurl-based/Dev/Mod/CPM.txt b/Trurl-based/Dev/Mod/CPM.txt new file mode 100644 index 0000000..71c432b --- /dev/null +++ b/Trurl-based/Dev/Mod/CPM.txt @@ -0,0 +1,853 @@ +MODULE DevCPM; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPM.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel, Files, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers; + + CONST + ProcSize* = 4; (* PROCEDURE type *) + PointerSize* = 4; (* POINTER type *) + DArrSizeA* = 8; (* dyn array descriptor *) + DArrSizeB* = 4; (* size = A + B * typ.n *) + + MaxSet* = 31; + MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *) + + MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *) + MinReal64PatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *) + MinReal64PatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *) + MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *) + MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *) + MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *) + InfRealPat = 07F800000H; (* real infinity pattern *) + + + (* inclusive range of parameter of standard procedure HALT *) + MinHaltNr* = 0; + MaxHaltNr* = 128; + + (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *) + MinRegNr* = 0; + MaxRegNr* = 31; + + (* maximal value of flag used to mark interface structures *) + MaxSysFlag* = 127; (* shortint *) + CProcFlag* = 1; (* code procedures *) + + (* maximal condition value of parameter of SYSTEM.CC *) + MaxCC* = 15; + + (* initialization of constant address, must be different from any valid constant address *) + ConstNotAlloc* = -1; + + (* whether hidden pointer fields have to be nevertheless exported *) + ExpHdPtrFld* = TRUE; + HdPtrName* = "@ptr"; + + (* whether hidden untagged pointer fields have to be nevertheless exported *) + ExpHdUtPtrFld* = TRUE; + HdUtPtrName* = "@utptr"; + + (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *) + ExpHdProcFld* = TRUE; + HdProcName* = "@proc"; + + (* whether hidden bound procedures have to be nevertheless exported *) + ExpHdTProc* = FALSE; + HdTProcName* = "@tproc"; + + (* maximal number of exported stuctures: *) + MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *) + + (* maximal number of record extensions: *) + MaxExts* = 15; (* defined by type descriptor layout *) + + (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *) + NEWusingAdr* = FALSE; + + (* special character (< " ") returned by procedure Get, if end of text reached *) + Eot* = 0X; + + (* warnings *) + longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7; + + (* language options *) + interface* = 1; + com* = 2; comAware* = 3; + som* = 4; somAware* = 5; + oberon* = 6; + java* = 7; javaAware* = 8; + noCode* = 9; + allSysVal* = 14; + sysImp* = 15; + trap* = 31; + sys386 = 10; sys68k = 20; (* processor type in options if system imported *) + + CONST + SFdir = "Sym"; + OFdir = "Code"; + SYSdir = "System"; + SFtag = 6F4F5346H; (* symbol file tag *) + OFtag = 6F4F4346H; (* object file tag *) + maxErrors = 64; + +TYPE + File = POINTER TO RECORD next: File; f: Files.File END; + + VAR + LEHost*: BOOLEAN; (* little or big endian host *) + MinReal32*, MaxReal32*, InfReal*, + MinReal64*, MaxReal64*: REAL; + noerr*: BOOLEAN; (* no error found until now *) + curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *) + searchpos*: INTEGER; (* search position in source file *) + errors*: INTEGER; + breakpc*: INTEGER; (* set by OPV.Init *) + options*: SET; (* language options *) + file*: Files.File; (* used for sym file import *) + codeDir*: ARRAY 16 OF CHAR; + symDir*: ARRAY 16 OF CHAR; + checksum*: INTEGER; (* symbol file checksum *) + + lastpos: INTEGER; + realpat: INTEGER; + lrealpat: RECORD H, L: INTEGER END; + fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR; + ObjFName: Files.Name; + + in: TextModels.Reader; + oldSymFile, symFile, objFile: Files.File; + inSym: Files.Reader; + outSym, outObj: Files.Writer; + + errNo, errPos: ARRAY maxErrors OF INTEGER; + + lineReader: TextModels.Reader; + lineNum: INTEGER; + + crc32tab: ARRAY 256 OF INTEGER; + + + PROCEDURE^ err* (n: INTEGER); + + PROCEDURE Init* (source: TextModels.Reader; logtext: TextModels.Model); + BEGIN + in := source; + DevMarkers.Unmark(in.Base()); + noerr := TRUE; options := {}; + curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0; + codeDir := OFdir; symDir := SFdir + END Init; + + PROCEDURE Close*; + BEGIN + oldSymFile := NIL; inSym := NIL; + symFile := NIL; outSym := NIL; + objFile := NIL; outObj := NIL; + in := NIL; lineReader := NIL + END Close; + + PROCEDURE Get* (VAR ch: SHORTCHAR); + VAR ch1: CHAR; + BEGIN + REPEAT in.ReadChar(ch1); INC(curpos) UNTIL (ch1 < 100X) & (ch1 # TextModels.viewcode); + ch := SHORT(ch1) + END Get; + + PROCEDURE GetL* (VAR ch: CHAR); + BEGIN + REPEAT in.ReadChar(ch); INC(curpos) UNTIL ch # TextModels.viewcode; + END GetL; + + PROCEDURE LineOf* (pos: INTEGER): INTEGER; + VAR ch: CHAR; + BEGIN + IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END; + IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END; + WHILE lineReader.Pos() < pos DO + lineReader.ReadChar(ch); + IF ch = 0DX THEN INC(lineNum) END + END; + RETURN lineNum + END LineOf; + + PROCEDURE LoWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF ~LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END LoWord; + + PROCEDURE HiWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END HiWord; + + PROCEDURE Compound (lo, hi: INTEGER): REAL; + VAR r: REAL; + BEGIN + IF LEHost THEN + SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi) + ELSE + SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi) + END; + RETURN r + END Compound; + + + (* sysflag control *) + + PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN; + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN + IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END; + i := 1; + WHILE i < 37 DO + ch := str[i]; + IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN + IF ch # "-" THEN RETURN FALSE END + ELSE + IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END + END; + INC(i) + END; + RETURN TRUE + END ValidGuid; + + PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF id # "" THEN + IF id = "code" THEN num := 1 + ELSIF id = "callback" THEN num := 2 + ELSIF id = "nostkchk" THEN num := 4 + ELSIF id = "ccall" THEN num := -10 + ELSIF id = "guarded" THEN num := 8 + ELSIF id = "noframe" THEN num := 16 + ELSIF id = "native" THEN num := -33 + ELSIF id = "bytecode" THEN num := -35 + END + END; + IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num) + ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num) + ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10 + ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8 + ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16 + ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num + ELSE err(225); flag := 0 + END + END GetProcSysFlag; + + PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (options * {sys386, sys68k, interface, com} # {}) THEN + IF (num = 1) OR (id = "nil") THEN + IF ~ODD(old) THEN flag := SHORT(old + 1) END + ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 2) END + ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 4) END + ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN + IF old <= 1 THEN flag := SHORT(old + 8) END + ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 16) END + END + END; + IF flag = 0 THEN err(225) END + END GetVarParSysFlag; + + PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 3) OR (id = "noalign") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END + ELSIF (num = 4) OR (id = "align2") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END + ELSIF (num = 5) OR (id = "align4") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END + ELSIF (num = 6) OR (id = "align8") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END + ELSIF (num = 7) OR (id = "union") THEN + IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END + ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = -11) OR (id = "jint") THEN + IF (java IN options) & (old = 0) THEN flag := -11 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetRecordSysFlag; + + PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = -12) OR (id = "jarr") THEN + IF (java IN options) & (old = 0) THEN flag := -12 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + END; + IF flag = 0 THEN err(225) END + END GetArraySysFlag; + + PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 2) OR (id = "handle") THEN + IF (sys68k IN options) & (old = 0) THEN flag := 2 END + ELSIF (num = 10) OR (id = "interface") THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetPointerSysFlag; + + PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10 + ELSE err(225); flag := 0 + END + END GetProcTypSysFlag; + + PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *) + IF flag = 0 THEN flag := baseFlag + ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *) + ELSIF flag # baseFlag THEN err(225); flag := 0 + END + ELSIF (baseFlag # 10) & (flag = 10) THEN err(225) + END + END PropagateRecordSysFlag; + + PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = 10 THEN (* pointer to interface is interface *) + IF flag = 0 THEN flag := 10 + ELSIF flag # 10 THEN err(225); flag := 0 + END + ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *) + IF flag # 0 THEN err(225) END; + flag := -11 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateRecPtrSysFlag; + + PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = -12 THEN (* pointer to java array is java array *) + IF flag # 0 THEN err(225) END; + flag := -12 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateArrPtrSysFlag; + + + (* utf8 strings *) + + PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER); + BEGIN + ASSERT((val >= 0) & (val < 65536)); + IF val < 128 THEN + str[idx] := SHORT(CHR(val)); INC(idx) + ELSIF val < 2048 THEN + str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + ELSE + str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); + str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + END + END PutUtf8; + + PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER); + VAR ch: SHORTCHAR; + BEGIN + ch := str[idx]; INC(idx); + IF ch < 80X THEN + val := ORD(ch) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + ELSE + val := ORD(ch) - 224; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + END + END GetUtf8; + + + (* log output *) + + PROCEDURE LogW* (ch: SHORTCHAR); + BEGIN + StdLog.Char(ch) + END LogW; + + PROCEDURE LogWStr* (s: ARRAY OF SHORTCHAR); + VAR str: ARRAY 256 OF CHAR; + BEGIN + str := s$; StdLog.String(str) + END LogWStr; + + PROCEDURE LogWNum* (i, len: INTEGER); + BEGIN + StdLog.Int(i) + END LogWNum; + + PROCEDURE LogWLn*; + BEGIN + StdLog.Ln + END LogWLn; +(* + PROCEDURE LogW* (ch: CHAR); + BEGIN + out.WriteChar(ch); + END LogW; + + PROCEDURE LogWStr* (s: ARRAY OF CHAR); + BEGIN + out.WriteString(s); + END LogWStr; + + PROCEDURE LogWNum* (i, len: LONGINT); + BEGIN + out.WriteChar(" "); out.WriteInt(i); + END LogWNum; + + PROCEDURE LogWLn*; + BEGIN + out.WriteLn; + Views.RestoreDomain(logbuf.Domain()) + END LogWLn; +*) + PROCEDURE Mark* (n, pos: INTEGER); + BEGIN + IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN + noerr := FALSE; + IF pos < 0 THEN pos := 0 END; + IF (pos < lastpos) OR (lastpos + 9 < pos) THEN + lastpos := pos; + IF errors < maxErrors THEN + errNo[errors] := n; errPos[errors] := pos + END; + INC(errors) + END; + IF trap IN options THEN HALT(100) END; + ELSIF (n <= -700) & (errors < maxErrors) THEN + errNo[errors] := -n; errPos[errors] := pos; INC(errors) + END + END Mark; + + PROCEDURE err* (n: INTEGER); + BEGIN + Mark(n, errpos) + END err; + + PROCEDURE InsertMarks* (text: TextModels.Model); + VAR i, j, x, y, n: INTEGER; script: Stores.Operation; + BEGIN + n := errors; + IF n > maxErrors THEN n := maxErrors END; + (* sort *) + i := 1; + WHILE i < n DO + x := errPos[i]; y := errNo[i]; j := i-1; + WHILE (j >= 0) & (errPos[j] > x) DO errPos[j+1] := errPos[j]; errNo[j+1] := errNo[j]; DEC(j) END; + errPos[j+1] := x; errNo[j+1] := y; INC(i) + END; + (* insert *) + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, "#Dev:InsertMarkers", script); + WHILE n > 0 DO DEC(n); + DevMarkers.Insert(text, errPos[n], DevMarkers.dir.New(errNo[n])) + END; + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END InsertMarks; + + + (* fingerprinting *) + + PROCEDURE InitCrcTab; + (* CRC32, high bit first, pre & post inverted *) + CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *) + VAR x, c, i: INTEGER; + BEGIN + x := 0; + WHILE x < 256 DO + c := x * 1000000H; i := 0; + WHILE i < 8 DO + IF c < 0 THEN c := ORD(BITS(c * 2) / poly) + ELSE c := c * 2 + END; + INC(i) + END; + crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255)); + INC(x) + END + END InitCrcTab; + + PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER); + VAR c: INTEGER; + BEGIN +(* + fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *) +*) + (* CRC32, high bit first, pre & post inverted *) + c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256])); + fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256])); + END FPrint; + + PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET); + BEGIN FPrint(fp, ORD(set)) + END FPrintSet; + + PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL); + BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real)) + END FPrintReal; + + PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL); + VAR l, h: INTEGER; + BEGIN + FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr)) + END FPrintLReal; + + PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *) + BEGIN + (* same as FPrint, 8 bit only *) + fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256])) + END ChkSum; + + + + (* compact format *) + + PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER); + BEGIN + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))) + END WriteLInt; + + PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; x: INTEGER; + BEGIN + r.ReadByte(b); x := b MOD 256; + ChkSum(checksum, b); + r.ReadByte(b); x := x + 100H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); x := x + 10000H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); i := x + 1000000H * b; + ChkSum(checksum, b) + END ReadLInt; + + PROCEDURE WriteNum (w: Files.Writer; i: INTEGER); + BEGIN (* old format of Oberon *) + WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END; + ChkSum(checksum, i MOD 128); + w.WriteByte(SHORT(SHORT(i MOD 128))) + END WriteNum; + + PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; r.ReadByte(b); + IF ~r.eof THEN ChkSum(checksum, b) END; + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y; + END ReadNum; + + PROCEDURE WriteNumSet (w: Files.Writer; x: SET); + BEGIN + WriteNum(w, ORD(x)) + END WriteNumSet; + + PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET); + VAR i: INTEGER; + BEGIN + ReadNum(r, i); x := BITS(i) + END ReadNumSet; + + PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL); + BEGIN + WriteLInt(w, SYSTEM.VAL(INTEGER, x)) + END WriteReal; + + PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL); + VAR i: INTEGER; + BEGIN + ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i) + END ReadReal; + + PROCEDURE WriteLReal (w: Files.Writer; x: REAL); + BEGIN + WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x)) + END WriteLReal; + + PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL); + VAR h, l: INTEGER; + BEGIN + ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h) + END ReadLReal; + + + (* read symbol file *) + + PROCEDURE SymRCh* (VAR ch: SHORTCHAR); + VAR b: BYTE; + BEGIN + inSym.ReadByte(b); ch := SHORT(CHR(b)); + ChkSum(checksum, b) + END SymRCh; + + PROCEDURE SymRInt* (): INTEGER; + VAR k: INTEGER; + BEGIN + ReadNum(inSym, k); RETURN k + END SymRInt; + + PROCEDURE SymRSet* (VAR s: SET); + BEGIN + ReadNumSet(inSym, s) + END SymRSet; + + PROCEDURE SymRReal* (VAR r: SHORTREAL); + BEGIN + ReadReal(inSym, r) + END SymRReal; + + PROCEDURE SymRLReal* (VAR lr: REAL); + BEGIN + ReadLReal(inSym, lr) + END SymRLReal; + + PROCEDURE eofSF* (): BOOLEAN; + BEGIN + RETURN inSym.eof + END eofSF; + + PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN); + VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name; + BEGIN + done := FALSE; + IF modName = "@file" THEN + oldSymFile := file + ELSE + name := modName$; Kernel.SplitName(name, dir, name); + Kernel.MakeFileName(name, Kernel.symType); + loc := Files.dir.This(dir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared); + IF (oldSymFile = NIL) & (dir = "") THEN + loc := Files.dir.This(SYSdir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared) + END + END; + IF oldSymFile # NIL THEN + inSym := oldSymFile.NewReader(inSym); + IF inSym # NIL THEN + ReadLInt(inSym, tag); + IF tag = SFtag THEN done := TRUE ELSE err(151) END + END + END + END OldSym; + + PROCEDURE CloseOldSym*; + BEGIN + IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END + END CloseOldSym; + + + (* write symbol file *) + + PROCEDURE SymWCh* (ch: SHORTCHAR); + BEGIN + ChkSum(checksum, ORD(ch)); + outSym.WriteByte(SHORT(ORD(ch))) + END SymWCh; + + PROCEDURE SymWInt* (i: INTEGER); + BEGIN + WriteNum(outSym, i) + END SymWInt; + + PROCEDURE SymWSet* (s: SET); + BEGIN + WriteNumSet(outSym, s) + END SymWSet; + + PROCEDURE SymWReal* (VAR r: SHORTREAL); + BEGIN + WriteReal(outSym, r) + END SymWReal; + + PROCEDURE SymWLReal* (VAR r: REAL); + BEGIN + WriteLReal(outSym, r) + END SymWLReal; + + PROCEDURE SymReset*; + BEGIN + outSym.SetPos(4) + END SymReset; + + PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(symDir); + symFile := Files.dir.New(loc, Files.ask); + IF symFile # NIL THEN + outSym := symFile.NewWriter(NIL); + WriteLInt(outSym, SFtag) + ELSE + err(153) + END + END NewSym; + + PROCEDURE RegisterNewSym*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF symFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.symType); + symFile.Register(name, Kernel.symType, Files.ask, res); + symFile := NIL + END + END RegisterNewSym; + + PROCEDURE DeleteNewSym*; + BEGIN + IF symFile # NIL THEN symFile.Close; symFile := NIL END + END DeleteNewSym; + + + (* write object file *) + + PROCEDURE ObjW* (ch: SHORTCHAR); + BEGIN + outObj.WriteByte(SHORT(ORD(ch))) + END ObjW; + + PROCEDURE ObjWNum* (i: INTEGER); + BEGIN + WriteNum(outObj, i) + END ObjWNum; + + PROCEDURE ObjWInt (i: SHORTINT); + BEGIN + outObj.WriteByte(SHORT(SHORT(i MOD 256))); + outObj.WriteByte(SHORT(SHORT(i DIV 256))) + END ObjWInt; + + PROCEDURE ObjWLInt* (i: INTEGER); + BEGIN + ObjWInt(SHORT(i MOD 65536)); + ObjWInt(SHORT(i DIV 65536)) + END ObjWLInt; + + PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER); + TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE; + VAR p: P; + BEGIN + p := SYSTEM.VAL(P, SYSTEM.ADR(bytes)); + outObj.WriteBytes(p^, 0, n) + END ObjWBytes; + + PROCEDURE ObjLen* (): INTEGER; + BEGIN + RETURN outObj.Pos() + END ObjLen; + + PROCEDURE ObjSet* (pos: INTEGER); + BEGIN + outObj.SetPos(pos) + END ObjSet; + + PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + errpos := 0; + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(codeDir); + objFile := Files.dir.New(loc, Files.ask); + IF objFile # NIL THEN + outObj := objFile.NewWriter(NIL); + WriteLInt(outObj, OFtag) + ELSE + err(153) + END + END NewObj; + + PROCEDURE RegisterObj*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF objFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.objType); + objFile.Register(name, Kernel.objType, Files.ask, res); + objFile := NIL; outObj := NIL + END + END RegisterObj; + + PROCEDURE DeleteObj*; + BEGIN + IF objFile # NIL THEN objFile.Close; objFile := NIL END + END DeleteObj; + + + PROCEDURE InitHost; + VAR test: SHORTINT; lo: SHORTCHAR; + BEGIN + test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X; + InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat); + MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat); + MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat); + MinReal64 := Compound(MinReal64PatL, MinReal64PatH); + MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH) + END InitHost; + +BEGIN + InitCrcTab; + InitHost +END DevCPM. diff --git a/Trurl-based/Dev/Mod/CPP.txt b/Trurl-based/Dev/Mod/CPP.txt new file mode 100644 index 0000000..b2fa032 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPP.txt @@ -0,0 +1,1650 @@ +MODULE DevCPP; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPP.odc *) + (* DO NOT EDIT *) + + IMPORT + DevCPM, DevCPT, DevCPB, DevCPS; + + CONST + anchorVarPar = TRUE; + + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + + (* node subclasses *) + super = 1; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13; + + + TYPE + Elem = POINTER TO RECORD + next: Elem; + struct: DevCPT.Struct; + obj, base: DevCPT.Object; + pos: INTEGER; + name: DevCPT.String + END; + + + VAR + sym, level: BYTE; + LoopLevel: SHORTINT; + TDinit, lastTDinit: DevCPT.Node; + userList: Elem; + recList: Elem; + hasReturn: BOOLEAN; + numUsafeVarPar, numFuncVarPar: INTEGER; + + + PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String); + PROCEDURE^ Expression(VAR x: DevCPT.Node); + PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node); + + (* forward type handling *) + + PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN; + BEGIN + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp) + END IncompleteType; + + PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String); + VAR u: Elem; + BEGIN + IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END; + IF name # NIL THEN + NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name; + u.next := userList; userList := u + END + END SetType; + + PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER); + BEGIN + typ.pvused := TRUE; + IF typ.comp = DynArr THEN + IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END + ELSIF typ.comp = Record THEN + IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN + DevCPM.Mark(193, pos); typ := DevCPT.undftyp + END + END + END CheckAlloc; + + PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER); + VAR fld: DevCPT.Object; + BEGIN + IF outer = inner THEN DevCPM.Mark(58, pos) + ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos) + ELSIF inner.comp = Record THEN + fld := inner.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + CheckRecursiveType(outer, fld.typ, pos); + fld := fld.link + END; + IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END + END + END CheckRecursiveType; + + PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + (* fix forward reference *) + VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT; + BEGIN + IF obj # NIL THEN + IF obj.mode = Var THEN (* variable type *) + IF struct # NIL THEN (* receiver type *) + IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END; + ELSE CheckAlloc(typ, obj.mnolev > level, pos) (* TRUE for parameters *) + END + ELSIF obj.mode = VarPar THEN (* varpar type *) + IF struct # NIL THEN (* varpar receiver type *) + IF typ # struct THEN DevCPM.Mark(180, pos) END + END + ELSIF obj.mode = Fld THEN (* field type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF obj.mode = TProc THEN (* proc return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END + ELSIF obj.mode = Typ THEN (* alias type *) + IF typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + t := DevCPT.NewStr(typ.form, Basic); i := t.ref; + t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0; + t.BaseTyp := typ; typ := t + END; + IF obj.vis # internal THEN + IF typ.comp = Record THEN typ.exp := TRUE + ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE + END + END + ELSE HALT(100) + END; + obj.typ := typ + ELSE + IF struct.form = Pointer THEN (* pointer base type *) + IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag) + ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag) + ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos) + END; + struct.untagged := struct.sysflag > 0; + IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END; + ELSIF struct.comp = Array THEN (* array base type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = DynArr THEN (* array base type *) + CheckAlloc(typ, TRUE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = Record THEN (* record base type *) + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1)); + DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag); + IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos) + ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos) + ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos) + END; + f := struct.link; + WHILE f # NIL DO (* check for field name conflicts *) + DevCPT.FindField(f.name, typ, bf); + IF bf # NIL THEN DevCPM.Mark(1, pos) END; + f := f.link + END; + CheckRecursiveType(struct, typ, pos); + struct.untagged := struct.sysflag > 0; + ELSIF struct.form = ProcTyp THEN (* proc type return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END; + ELSE HALT(100) + END; + struct.BaseTyp := typ + END + END FixType; + + PROCEDURE CheckForwardTypes; + VAR u, next: Elem; progress: BOOLEAN; + BEGIN + u := userList; userList := NIL; + WHILE u # NIL DO + next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base); + IF u.base = NIL THEN DevCPM.Mark(0, u.pos) + ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos) + ELSE u.next := userList; userList := u (* reinsert *) + END; + u := next + END; + REPEAT (* iteration for multy level alias *) + u := userList; userList := NIL; progress := FALSE; + WHILE u # NIL DO + next := u.next; + IF IncompleteType(u.base.typ) THEN + u.next := userList; userList := u (* reinsert *) + ELSE + progress := TRUE; + FixType(u.struct, u.obj, u.base.typ, u.pos) + END; + u := next + END + UNTIL (userList = NIL) OR ~progress; + u := userList; (* remaining type relations are cyclic *) + WHILE u # NIL DO + IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END; + u := u.next + END; + END CheckForwardTypes; + + PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + VAR obj: DevCPT.Object; + BEGIN + IF m # NIL THEN + IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN + DevCPT.FindField(m.name^, typ, obj); + IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN + DevCPM.Mark(192, pos); + DevCPM.LogWLn; DevCPM.LogWStr(" "); DevCPM.LogWStr(m.name^); + DevCPM.LogWStr(" not implemented"); + IF typ.strobj # NIL THEN + DevCPM.LogWStr(" in "); DevCPM.LogWStr(typ.strobj.name^) + END + END + END; + CheckUnimpl(m.left, typ, pos); + CheckUnimpl(m.right, typ, pos) + END + END CheckUnimpl; + + PROCEDURE CheckRecords (rec: Elem); + VAR b: DevCPT.Struct; + BEGIN + WHILE rec # NIL DO (* check for unimplemented methods in base type *) + b := rec.struct.BaseTyp; + WHILE (b # NIL) & (b # DevCPT.undftyp) DO + CheckUnimpl(b.link, rec.struct, rec.pos); + b := b.BaseTyp + END; + rec := rec.next + END + END CheckRecords; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE CheckSym(s: SHORTINT); + BEGIN + IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END + END CheckSym; + + PROCEDURE qualident(VAR id: DevCPT.Object); + VAR obj: DevCPT.Object; lev: BYTE; + BEGIN (*sym = ident*) + DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym); + IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym) + ELSE err(ident); obj := NIL + END + END ; + IF obj = NIL THEN err(0); + obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0 + ELSE lev := obj.mnolev; + IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN + obj.leaf := FALSE; + IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END (* !!! *) + END + END ; + id := obj + END qualident; + + PROCEDURE ConstExpression(VAR x: DevCPT.Node); + BEGIN Expression(x); + IF x.class # Nconst THEN + err(50); x := DevCPB.NewIntConst(1) + END + END ConstExpression; + + PROCEDURE CheckMark(obj: DevCPT.Object); (* !!! *) + VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String; + BEGIN DevCPS.Get(sym); + IF (sym = times) OR (sym = minus) THEN + IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ; + IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ; + DevCPS.Get(sym) + ELSE obj.vis := internal + END; + IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); n := 0; + IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + obj.library := obj.entry; obj.entry := NIL; + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); + ELSE err(string) + END + END; + WHILE sym = comma DO + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n) + ELSE err(235) + END; + DevCPS.Get(sym) + ELSE err(string) + END + END; + IF n > 0 THEN + NEW(obj.modifiers, n); + WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END + END + ELSE err(string) + END; + CheckSym(rbrak); + IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END + END + END CheckMark; + + PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT; + GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT)); + VAR x: DevCPT.Object; i: SHORTINT; + BEGIN + sysflag := 0; + IF sym = lbrak THEN + DevCPS.Get(sym); + WHILE (sym = number) OR (sym = ident) OR (sym = string) DO + IF sym = number THEN + IF DevCPS.numtyp = integer THEN + i := SHORT(DevCPS.intval); GetSF("", i, sysflag) + ELSE err(225) + END + ELSIF sym = ident THEN + DevCPT.Find(DevCPS.name, x); + IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN + i := SHORT(x.conval.intval); GetSF("", i, sysflag) + ELSE + GetSF(DevCPS.name, 0, sysflag) + END + ELSE + GetSF(DevCPS.str^, 0, sysflag) + END; + DevCPS.Get(sym); + IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END + END; + CheckSym(rbrak) + END + END CheckSysFlag; + + PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct); + VAR obj: DevCPT.Object; tname: DevCPT.String; + BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar; + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar (* ??? *) + ELSE mode := Var + END ; + name := DevCPS.name; CheckSym(ident); CheckSym(colon); + IF sym # ident THEN err(ident) END; + Type(typ, tname); + IF tname = NIL THEN + IF typ.form = Pointer THEN rec := typ.BaseTyp ELSE rec := typ END; + IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR + (mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END; + IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END + ELSE err(0) + END; + CheckSym(rparen); + IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END + END Receiver; + + PROCEDURE FormalParameters( + VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String + ); + VAR mode, vis: BYTE; sys: SHORTINT; + par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct; + BEGIN + first := NIL; last := firstPar; + newPar := NIL; iidPar := NIL; + IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN + LOOP + sys := 0; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar + ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar + ELSE mode := Var + END ; + IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END; + IF ODD(sys DIV inBit) THEN vis := inPar + ELSIF ODD(sys DIV outBit) THEN vis := outPar + END; + IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225) + ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225) + END; + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym); + par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys); + IF first = NIL THEN first := par END ; + IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ; + last := par + ELSE err(ident) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSIF sym = var THEN err(comma); DevCPS.Get(sym) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END; + IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177) + END; + (* typ.pbused is set when parameter type name is parsed *) + WHILE first # NIL DO + SetType (NIL, first, typ, name); + IF DevCPM.com IN DevCPM.options THEN + IF ODD(sys DIV newBit) THEN + IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END; + newPar := first + ELSIF ODD(sys DIV iidBit) THEN + IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END; + iidPar := first + END + END; + first := first.link + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END + END; + CheckSym(rparen); + IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END; + name := NIL; + IF sym = colon THEN + DevCPS.Get(sym); + Type(resTyp, name); + IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END + ELSE resTyp := DevCPT.notyp + END + END FormalParameters; + + PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct); + VAR o, bo: DevCPT.Object; + BEGIN + IF base # NIL THEN + IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END; + IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis) + OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END; + o := proc.link; bo := base.link; + WHILE (o # NIL) & (bo # NIL) DO + IF (bo.sysflag # 0) & (o.sysflag = 0) THEN (* propagate sysflags *) + o.sysflag := bo.sysflag + END; + o := o.link; bo := bo.link + END; + DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE); + IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END; + IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END; + INCL(proc.conval.setval, isRedef) + END; + END CheckOverwrite; + + PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct); (* read method attributes *) + VAR attr, battr: SET; o: DevCPT.Object; + BEGIN + attr := {}; + IF sym = comma THEN (* read attributes *) + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.Find(DevCPS.name, o); + IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN + IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END; + DevCPS.Get(sym); + IF sym = comma THEN + DevCPS.Get(sym); + IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END + ELSE o := NIL + END + END; + IF o # NIL THEN + IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178) + ELSE INCL(attr, o.adr) + END; + DevCPS.Get(sym) + END + ELSE err(ident) + END + END; + IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr) + ELSIF (base # NIL) & (newAttr IN attr) THEN err(186) + END; + IF absAttr IN attr THEN + IF owner.attribute # absAttr THEN err(190) END; + IF (proc.vis = internal) & owner.exp THEN err(179) END + END; + IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN + IF (empAttr IN attr) & (newAttr IN attr) THEN err(187) +(* + ELSIF extAttr IN attr THEN err(188) +*) + END + END; + IF base # NIL THEN + battr := base.conval.setval; + IF empAttr IN battr THEN + IF absAttr IN attr THEN err(189) END + ELSIF ~(absAttr IN battr) THEN + IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END + END + END; + IF empAttr IN attr THEN + IF proc.typ # DevCPT.notyp THEN err(195) + ELSE + o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END; + IF o # NIL THEN err(195) END + END + END; + IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END; + proc.conval.setval := attr + END GetAttributes; + + PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object); + VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL; + CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag); + IF attr # NIL THEN + IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr)) + ELSE err(178) + END + END; + IF typ.sysflag = interface THEN + IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END; + IF typ.attribute # absAttr THEN err(163) END; + IF sym # lparen THEN err(160) END + END; + IF sym = lparen THEN + DevCPS.Get(sym); (*record extension*) + IF sym = ident THEN + Type(ftyp, name); + IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END; + SetType(typ, NIL, ftyp, name); + IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN + ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1)); + DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag); + IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181) + ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191) + ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197) + END + ELSIF ftyp # DevCPT.undftyp THEN err(53) + END + ELSE err(ident) + END ; + IF typ.attribute # absAttr THEN (* save typ for unimplemented method check *) + NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r + END; + CheckSym(rparen) + END; +(* + DevCPT.OpenScope(0, NIL); +*) + first := NIL; last := NIL; + LOOP + IF sym = ident THEN + LOOP + IF sym = ident THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN + DevCPT.FindBaseField(DevCPS.name, typ, fld); + IF fld # NIL THEN err(1) END + END ; + DevCPT.InsertField(DevCPS.name, typ, fld); + fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp; + CheckMark(fld); + IF first = NIL THEN first := fld END ; + IF last = NIL THEN typ.link := fld ELSE last.link := fld END ; + last := fld + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(ftyp, name); + CheckAlloc(ftyp, FALSE, DevCPM.errpos); + WHILE first # NIL DO + SetType(typ, first, ftyp, name); first := first.link + END; + IF typ.sysflag = interface THEN err(161) END + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END; +(* + IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END; + typ.link := DevCPT.topScope.right; DevCPT.CloseScope; +*) + typ.untagged := typ.sysflag > 0; + DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) + END RecordType; + + PROCEDURE ArrayType(VAR typ: DevCPT.Struct); + VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String; + BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag); + IF sym = of THEN (*dynamic array*) + typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag; + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END + ELSE + typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x); + IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval; + IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END + ELSE err(42); n := 1 + END ; + typ.n := n; + IF sym = of THEN + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos) + ELSIF sym = comma THEN + DevCPS.Get(sym); + IF sym # of THEN ArrayType(typ.BaseTyp) END + ELSE err(35) + END + END; + typ.untagged := typ.sysflag > 0 + END ArrayType; + + PROCEDURE PointerType(VAR typ: DevCPT.Struct); + VAR id: DevCPT.Object; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag); + CheckSym(to); + Type(typ.BaseTyp, name); + SetType(typ, NIL, typ.BaseTyp, name); + IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN + typ.BaseTyp := DevCPT.undftyp; err(57) + END; + IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + END; + typ.untagged := typ.sysflag > 0 + END PointerType; + + PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String); (* name # NIL => forward reference *) + VAR id: DevCPT.Object; tname: DevCPT.String; + BEGIN + typ := DevCPT.undftyp; name := NIL; + IF sym < lparen THEN err(12); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + DevCPT.Find(DevCPS.name, id); + IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN (* forward type definition *) + name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym); + IF (id = NIL) & (sym = period) THEN (* missing module *) + err(0); DevCPS.Get(sym); name := NIL; + IF sym = ident THEN DevCPS.Get(sym) END + ELSIF sym = record THEN (* wrong attribute *) + err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL) + END + ELSE + qualident(id); + IF id.mode = Typ THEN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN + err(198) + END; + typ := id.typ + ELSIF id.mode = Attr THEN + IF sym = record THEN + DevCPS.Get(sym); RecordType(typ, id) + ELSE err(12) + END + ELSE err(52) + END + END + ELSIF sym = array THEN + DevCPS.Get(sym); ArrayType(typ) + ELSIF sym = record THEN + DevCPS.Get(sym); RecordType(typ, NIL) + ELSIF sym = pointer THEN + DevCPS.Get(sym); PointerType(typ) + ELSIF sym = procedure THEN + DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic); + CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag); + typ.untagged := typ.sysflag > 0; + IF sym = lparen THEN + DevCPS.Get(sym); DevCPT.OpenScope(level, NIL); + FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope + ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL + END + ELSE err(12) + END ; + LOOP + IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) + OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END; + err(15); IF sym = ident THEN EXIT END; + DevCPS.Get(sym) + END + END Type; + + PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node); + VAR apar, last, newPar, iidPar, n: DevCPT.Node; + BEGIN + aparlist := NIL; last := NIL; + IF sym # rparen THEN + newPar := NIL; iidPar := NIL; + LOOP Expression(apar); + IF fpar # NIL THEN + IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END; + DevCPB.Param(apar, fpar); + IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END; + DevCPB.Link(aparlist, last, apar); + IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar + ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar + END; + IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END; + IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options) + OR (DevCPM.allSysVal IN DevCPM.options) (* source output: avoid double evaluation *) + & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged + OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN + n := apar; + WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 0) THEN + IF n.left.class = Nguard THEN n := n.left END; + DevCPB.CheckVarParBuffering(n.left, pre, lastp) + END + END; + fpar := fpar.link + ELSE err(64) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END + END; + IF fpar # NIL THEN err(65) END + END ActualParameters; + + PROCEDURE selector(VAR x: DevCPT.Node); + VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name; + BEGIN + LOOP + IF sym = lbrak THEN DevCPS.Get(sym); + LOOP + IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ; + Expression(y); DevCPB.Index(x, y); + IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END + END ; + CheckSym(rbrak) + ELSIF sym = period THEN DevCPS.Get(sym); + IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym); + IF x.typ # NIL THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ; + IF x.typ.comp = Record THEN + typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj); + IF (obj # NIL) & (obj.mode = TProc) THEN + IF sym = arrow THEN (* super call *) DevCPS.Get(sym); + y := x.left; + IF y.class = Nderef THEN y := y.left END ; (* y = record variable *) + IF y.obj # NIL THEN + proc := DevCPT.topScope; (* find innermost scope which owner is a TProc *) + WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ; + IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75) + END ; + typ := y.obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END ; + DevCPT.FindBaseField(x.obj.name^, typ, p); + IF p # NIL THEN + x.subcl := super; x.typ := p.typ; (* correct result type *) + IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END; + IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END; + ELSE err(74) + END + ELSE err(75) + END + ELSE + proc := obj; + WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO + (* find base method *) + typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc); + END; + IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END; + END ; + IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END + END + ELSE err(53) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x) + ELSIF sym = dollar THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + DevCPS.Get(sym); DevCPB.StrDeref(x) + ELSIF sym = lparen THEN + IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ + ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp + ELSIF x.class = Nproc THEN EXIT (* standard procedure *) + ELSE typ := NIL + END; + IF typ # DevCPT.notyp THEN + DevCPS.Get(sym); + IF typ = NIL THEN (* type guard *) + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END + ELSE (* function call *) + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) + END; + ActualParameters(apar, fpar, pre, lastp); + DevCPB.Call(x, apar, fpar); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END; + CheckSym(rparen) + ELSE EXIT + END +(* + ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) & + ((x.obj = NIL) OR (x.obj.mode # TProc)) THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END ; + CheckSym(rparen) +*) + ELSE EXIT + END + END + END selector; + + PROCEDURE StandProcCall(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; m: BYTE; n: SHORTINT; + BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0; + IF sym = lparen THEN DevCPS.Get(sym); + IF sym # rparen THEN + LOOP + IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1 + ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2 + ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(rparen) + ELSE DevCPS.Get(sym) + END ; + DevCPB.StFct(x, m, n) + ELSE err(lparen) + END ; + IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END + END StandProcCall; + + PROCEDURE Element(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN Expression(x); + IF sym = upto THEN + DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y) + ELSE DevCPB.SetElem(x) + END + END Element; + + PROCEDURE Sets(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN + IF sym # rbrace THEN + Element(x); + LOOP + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END ; + Element(y); DevCPB.Op(plus, x, y) + END + ELSE x := DevCPB.EmptySet() + END ; + CheckSym(rbrace) + END Sets; + + PROCEDURE Factor(VAR x: DevCPT.Node); + VAR fpar, id: DevCPT.Object; apar: DevCPT.Node; + BEGIN + IF sym < not THEN err(13); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) +(* + ELSIF sym = lparen THEN + DevCPS.Get(sym); DevCPB.PrepCall(x, fpar); + ActualParameters(apar, fpar); + DevCPB.Call(x, apar, fpar); + CheckSym(rparen); + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END +*) + END + ELSIF sym = number THEN + CASE DevCPS.numtyp OF + char: + x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ; + IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END + | integer: x := DevCPB.NewIntConst(DevCPS.intval) + | int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval) + | real: x := DevCPB.NewRealConst(DevCPS.realval, NIL) + | real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ) + | real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ) + END ; + DevCPS.Get(sym) + ELSIF sym = string THEN + x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval); + DevCPS.Get(sym) + ELSIF sym = nil THEN + x := DevCPB.Nil(); DevCPS.Get(sym) + ELSIF sym = lparen THEN + DevCPS.Get(sym); Expression(x); CheckSym(rparen) + ELSIF sym = lbrak THEN + DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) + ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x) + ELSIF sym = not THEN + DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x) + ELSE err(13); DevCPS.Get(sym); x := NIL + END ; + IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END + END Factor; + + PROCEDURE Term(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; mulop: BYTE; + BEGIN Factor(x); + WHILE (times <= sym) & (sym <= and) DO + mulop := sym; DevCPS.Get(sym); + Factor(y); DevCPB.Op(mulop, x, y) + END + END Term; + + PROCEDURE SimpleExpression(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; addop: BYTE; + BEGIN + IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x) + ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x) + ELSE Term(x) + END ; + WHILE (plus <= sym) & (sym <= or) DO + addop := sym; DevCPS.Get(sym); Term(y); + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(x) + END; + IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(y) + END; + DevCPB.Op(addop, x, y) + END + END SimpleExpression; + + PROCEDURE Expression(VAR x: DevCPT.Node); + VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE; + BEGIN SimpleExpression(x); + IF (eql <= sym) & (sym <= geq) THEN + relation := sym; DevCPS.Get(sym); SimpleExpression(y); + pre := NIL; last := NIL; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(x) + END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(y) + END; + DevCPB.CheckBuffering(x, NIL, NIL, pre, last); + DevCPB.CheckBuffering(y, NIL, NIL, pre, last); + DevCPB.Op(relation, x, y); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END + ELSIF sym = in THEN + DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y) + ELSIF sym = is THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE) + ELSE err(52) + END + ELSE err(ident) + END + END + END Expression; + + PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node); + VAR proc, fwd: DevCPT.Object; + name: DevCPT.Name; + mode: BYTE; + forward: BOOLEAN; + sys: SHORTINT; + + PROCEDURE GetCode; + VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR; + BEGIN + n := 0; + IF sym = string THEN + NEW(ext, DevCPS.intval); + WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ; + ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym); + ELSE + LOOP + IF sym = number THEN c := DevCPS.intval; INC(n); + IF (c < 0) OR (c > 255) OR (n = 255) THEN + err(64); c := 1; n := 1 + END ; + DevCPS.Get(sym); s[n] := SHORT(CHR(c)) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = number THEN err(comma) + ELSE s[0] := SHORT(CHR(n)); EXIT + END + END; + NEW(ext, n + 1); i := 0; + WHILE i <= n DO ext[i] := s[i]; INC(i) END; + END; + proc.conval.ext := ext; + INCL(proc.conval.setval, hasBody) + END GetCode; + + PROCEDURE GetParams; + VAR name: DevCPT.String; + BEGIN + proc.mode := mode; proc.typ := DevCPT.notyp; + proc.sysflag := SHORT(sys); + proc.conval.setval := {}; + IF sym = lparen THEN + DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name); + IF name # NIL THEN err(0) END + END; + CheckForwardTypes; userList := NIL; + IF fwd # NIL THEN + DevCPB.CheckParameters(proc.link, fwd.link, TRUE); + IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ; + proc := fwd; DevCPT.topScope := proc.scope; + IF mode = IProc THEN proc.mode := IProc END + END + END GetParams; + + PROCEDURE Body; + VAR procdec, statseq: DevCPT.Node; c: INTEGER; + BEGIN + c := DevCPM.errpos; + INCL(proc.conval.setval, hasBody); + CheckSym(semicolon); Block(procdec, statseq); + DevCPB.Enter(procdec, statseq, proc); x := procdec; + x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # proc.name^ THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END + END Body; + + PROCEDURE TProcDecl; + VAR baseProc, o, bo: DevCPT.Object; + objTyp, recTyp: DevCPT.Struct; + objMode, objVis: BYTE; + objName: DevCPT.Name; + pnode: DevCPT.Node; + fwdAttr: SET; + BEGIN + DevCPS.Get(sym); mode := TProc; + IF level > 0 THEN err(73) END; + Receiver(objMode, objVis, objName, objTyp, recTyp); + IF sym = ident THEN + name := DevCPS.name; + DevCPT.FindField(name, recTyp, fwd); + DevCPT.FindBaseField(name, recTyp, baseProc); + IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ; + IF fwd = baseProc THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END; + fwdAttr := fwd.conval.setval + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.InsertField(name, recTyp, proc); + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF recTyp.strobj # NIL THEN (* preserve declaration order *) + o := recTyp.strobj.link; + IF o = NIL THEN recTyp.strobj.link := proc + ELSE + WHILE o.nlink # NIL DO o := o.nlink END; + o.nlink := proc + END + END + END; + INC(level); DevCPT.OpenScope(level, proc); + DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp; + ASSERT(DevCPT.topScope # NIL); + GetParams; (* may change proc := fwd !!! *) + ASSERT(DevCPT.topScope # NIL); + GetAttributes(proc, baseProc, recTyp); + IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END; + CheckOverwrite(proc, baseProc, recTyp); + IF ~forward THEN + IF empAttr IN proc.conval.setval THEN (* insert empty procedure *) + pnode := NIL; DevCPB.Enter(pnode, NIL, proc); + pnode.conval := DevCPT.NewConst(); + pnode.conval.intval := DevCPM.errpos; + pnode.conval.intval2 := DevCPM.errpos; + x := pnode; + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~(absAttr IN proc.conval.setval) THEN Body + END; + proc.adr := 0 + ELSE + proc.adr := DevCPM.errpos; + IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END + END; + DEC(level); DevCPT.CloseScope; + ELSE err(ident) + END; + END TProcDecl; + + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0; + IF (sym # ident) & (sym # lparen) THEN + CheckSysFlag(sys, DevCPM.GetProcSysFlag); + IF sys # 0 THEN + IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END + ELSE + IF sym = times THEN (* mode set later in DevCPB.CheckAssign *) + ELSIF sym = arrow THEN forward := TRUE + ELSE err(ident) + END; + DevCPS.Get(sym) + END + END ; + IF sym = lparen THEN TProcDecl + ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd); + name := DevCPS.name; + IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.Insert(name, proc); + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + END ; + IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ; + IF (mode # LProc) & (level > 0) THEN err(73) END ; + INC(level); DevCPT.OpenScope(level, proc); + proc.link := NIL; GetParams; (* may change proc := fwd !!! *) + IF mode = CProc THEN GetCode + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~forward THEN Body; proc.adr := 0 + ELSE proc.adr := DevCPM.errpos + END ; + DEC(level); DevCPT.CloseScope + ELSE err(ident) + END + END ProcedureDeclaration; + + PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER); + VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER; + + PROCEDURE Insert(VAR n: DevCPT.Node); (* build binary tree of label ranges *) (* !!! *) + BEGIN + IF n = NIL THEN + IF x.hint # 1 THEN n := x END + ELSIF yval < n.conval.intval THEN Insert(n.left) + ELSIF xval > n.conval.intval2 THEN Insert(n.right) + ELSE err(63) + END + END Insert; + + BEGIN lab := NIL; lastlab := NIL; + LOOP ConstExpression(x); f := x.typ.form; + IF f IN {Int8..Int32} + charSet THEN xval := x.conval.intval + ELSE err(61); xval := 1 + END ; + IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF sym = upto THEN + DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval; + IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF yval < xval THEN err(63); yval := xval END + ELSE yval := xval + END ; + x.conval.intval2 := yval; + IF xval < min THEN min := xval END; + IF yval > max THEN max := yval END; + IF lab = NIL THEN lab := x; Insert(root) + ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root) + ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval + ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval + ELSE + y := lab; + WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END; + IF y.link = NIL THEN y.link := x; Insert(root) + ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root) + ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval + ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval + END + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (sym = number) OR (sym = ident) THEN err(comma) + ELSE EXIT + END + END + END CaseLabelList; + + PROCEDURE StatSeq(VAR stat: DevCPT.Node); + VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN; + s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name; + + PROCEDURE CasePart(VAR x: DevCPT.Node); + VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node; + BEGIN + Expression(x); + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.form = Int64 THEN err(260) + ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125) + END ; + CheckSym(of); cases := NIL; lastcase := NIL; root := NIL; + low := MAX(INTEGER); high := MIN(INTEGER); + LOOP + IF sym < bar THEN + CaseLabelList(lab, root, x.typ.form, low, high); + CheckSym(colon); StatSeq(y); + DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab) + END ; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; + IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases); + cases.conval := DevCPT.NewConst(); + cases.conval.intval := low; cases.conval.intval2 := high; + IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END; + DevCPB.OptimizeCase(root); cases.link := root (* !!! *) + END CasePart; + + PROCEDURE SetPos(x: DevCPT.Node); + BEGIN + x.conval := DevCPT.NewConst(); x.conval.intval := pos + END SetPos; + + PROCEDURE CheckBool(VAR x: DevCPT.Node); + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE) + ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE) + END + END CheckBool; + + BEGIN stat := NIL; last := NIL; + LOOP x := NIL; + IF sym < ident THEN err(14); + REPEAT DevCPS.Get(sym) UNTIL sym >= ident + END ; + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF sym = becomes THEN + DevCPS.Get(sym); Expression(y); + IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END; + pre := NIL; lastp := NIL; + DevCPB.CheckBuffering(y, x, NIL, pre, lastp); + DevCPB.Assign(x, y); + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + ELSIF sym = eql THEN + err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y) + ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN + StandProcCall(x); + IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END; + IF (x # NIL) & (x.class = Nifelse) THEN (* error pos for ASSERT *) + SetPos(x.left); SetPos(x.left.right) + END + ELSIF x.class = Ncall THEN err(55) + ELSE + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END; + IF sym = lparen THEN + DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen) + ELSE apar := NIL; + IF fpar # NIL THEN err(65) END + END ; + DevCPB.Call(x, apar, fpar); + IF x.typ # DevCPT.notyp THEN err(55) END; + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END + ELSIF sym = if THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); + DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x; + WHILE sym = elsif DO + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); + DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y) + END ; + pos := DevCPM.startpos; + IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x); + ELSIF sym = case THEN + DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end) + ELSIF sym = while THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); + DevCPB.Construct(Nwhile, x, y); CheckSym(end) + ELSIF sym = repeat THEN + DevCPS.Get(sym); StatSeq(x); + IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y) + ELSE err(43) + END ; + DevCPB.Construct(Nrepeat, x, y) + ELSIF sym = for THEN + DevCPS.Get(sym); pos := DevCPM.startpos; + IF sym = ident THEN qualident(id); + IF ~(id.typ.form IN intSet) THEN err(68) END ; + CheckSym(becomes); Expression(y); + x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x); + CheckSym(to); pos := DevCPM.startpos; Expression(y); + IF y.class # Nconst THEN + DevCPB.GetTempVar("@for", x.left.typ, t); + z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z); + y := DevCPB.NewLeaf(t) + ELSE + DevCPB.CheckAssign(x.left.typ, y) + END ; + DevCPB.Link(stat, last, x); + p := DevCPM.startpos; + IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ; + x := DevCPB.NewLeaf(id); + IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y) + ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y) + ELSE err(63); DevCPB.Op(geq, x, y) + END ; + CheckSym(do); StatSeq(s); + y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y); + IF s = NIL THEN s := y + ELSE z := s; + WHILE z.link # NIL DO z := z.link END ; + z.link := y + END ; + CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p + ELSE err(ident) + END + ELSIF sym = loop THEN + DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); + DevCPB.Construct(Nloop, x, NIL); CheckSym(end) + ELSIF sym = with THEN + DevCPS.Get(sym); idtyp := NIL; x := NIL; + LOOP + IF sym < bar THEN + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); y := DevCPB.NewLeaf(id); + IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN + err(-302) (* warning 302 *) + END ; + CheckSym(colon); + IF sym = ident THEN qualident(t); + IF t.mode = Typ THEN + IF id # NIL THEN + idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ; + IF id.ptyp = NIL THEN id.ptyp := idtyp END + ELSE err(130) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSE err(ident) + END ; + CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y); + IF idtyp # NIL THEN + IF id.ptyp = idtyp THEN id.ptyp := NIL END; + id.typ := idtyp; idtyp := NIL + END ; + IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END + END; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; pos := DevCPM.startpos; + IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ; + DevCPB.Construct(Nwith, x, s); CheckSym(end); + IF e THEN x.subcl := 1 END + ELSIF sym = exit THEN + DevCPS.Get(sym); + IF LoopLevel = 0 THEN err(46) END ; + DevCPB.Construct(Nexit, x, NIL) + ELSIF sym = return THEN DevCPS.Get(sym); + IF sym < semicolon THEN Expression(x) END ; + IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link) + ELSE (* not standard Oberon *) DevCPB.Return(x, NIL) + END; + hasReturn := TRUE + END ; + IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + ELSE EXIT + END + END + END StatSeq; + + PROCEDURE Block(VAR procdec, statseq: DevCPT.Node); + VAR typ: DevCPT.Struct; + obj, first, last, o: DevCPT.Object; + x, lastdec: DevCPT.Node; + i: SHORTINT; + rname: DevCPT.Name; + name: DevCPT.String; + rec: Elem; + + BEGIN + IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END; + first := NIL; last := NIL; userList := NIL; recList := NIL; + LOOP + IF sym = const THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Con; CheckMark(obj); + obj.typ := DevCPT.int8typ; obj.mode := Var; (* Var to avoid recursive definition *) + IF sym = eql THEN + DevCPS.Get(sym); ConstExpression(x) + ELSIF sym = becomes THEN + err(eql); DevCPS.Get(sym); ConstExpression(x) + ELSE err(eql); x := DevCPB.NewIntConst(1) + END ; + obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *) + CheckSym(semicolon) + END + END ; + IF sym = type THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp; + CheckMark(obj); obj.mode := -1; + IF sym # eql THEN err(eql) END; + IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN + DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name); + END; + obj.mode := Typ; + IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref; + typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos; + typ.BaseTyp := obj.typ; obj.typ := typ; + END; + IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ; + IF obj.typ.form = Pointer THEN (* !!! *) + typ := obj.typ.BaseTyp; + IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN + (* pointer to unnamed record: name record as "pointerName^" *) + rname := obj.name^$; i := 0; + WHILE rname[i] # 0X DO INC(i) END; + rname[i] := "^"; rname[i+1] := 0X; + DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o + END + END; + IF obj.vis # internal THEN + typ := obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF typ.comp = Record THEN typ.exp := TRUE END + END; + CheckSym(semicolon) + END + END ; + IF sym = var THEN + DevCPS.Get(sym); + WHILE sym = ident DO + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp; + CheckMark(obj); + IF first = NIL THEN first := obj END ; + IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ; + last := obj + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + CheckAlloc(typ, FALSE, DevCPM.errpos); + WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ; + CheckSym(semicolon) + END + END ; + IF (sym < const) OR (sym > var) THEN EXIT END ; + END ; + CheckForwardTypes; + userList := NIL; rec := recList; recList := NIL; + DevCPT.topScope.adr := DevCPM.errpos; + procdec := NIL; lastdec := NIL; + IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END; + WHILE sym = procedure DO + DevCPS.Get(sym); ProcedureDeclaration(x); + IF x # NIL THEN + IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ; + lastdec := x + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END; + hasReturn := FALSE; + IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END; + IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq) + ELSE statseq := NIL + END ; + IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp) + & ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END; + IF (level = 0) & (TDinit # NIL) THEN + lastTDinit.link := statseq; statseq := TDinit + END + END Block; + + PROCEDURE Module*(VAR prog: DevCPT.Node); + VAR impName, aliasName: DevCPT.Name; + procdec, statseq: DevCPT.Node; + c, sf: INTEGER; done: BOOLEAN; + BEGIN + DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym); + IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ; + IF sym = ident THEN + DevCPT.Open(DevCPS.name); DevCPS.Get(sym); + DevCPT.libName := ""; + IF sym = lbrak THEN + INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym); + IF sym = eql THEN DevCPS.Get(sym) + ELSE INCL(DevCPM.options, DevCPM.noCode) + END; + IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym) + ELSE err(string) + END; + CheckSym(rbrak) + END; + CheckSym(semicolon); + IF sym = import THEN DevCPS.Get(sym); + LOOP + IF sym = ident THEN + aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym); + IF sym = becomes THEN DevCPS.Get(sym); + IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END + END ; + DevCPT.Import(aliasName, impName, done) + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos; + Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec; + prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos; + IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END; + prog.conval.realval := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # DevCPT.SelfName THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END; + IF sym # period THEN err(period) END + END + ELSE err(ident) + END ; + TDinit := NIL; lastTDinit := NIL; + DevCPS.str := NIL + END Module; + +END DevCPP. diff --git a/Trurl-based/Dev/Mod/CPS.txt b/Trurl-based/Dev/Mod/CPS.txt new file mode 100644 index 0000000..ea2d746 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPS.txt @@ -0,0 +1,367 @@ +MODULE DevCPS; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPS.odc *) + (* DO NOT EDIT *) + (* SEE XXX *) + + IMPORT SYSTEM, Math, DevCPM, DevCPT; + + CONST + MaxIdLen = 256; + + TYPE +(* + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; +*) + + (* name, str, numtyp, intval, realval, realval are implicit results of Get *) + + VAR + name*: DevCPT.Name; + str*: DevCPT.String; + lstr*: POINTER TO ARRAY OF CHAR; + numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *) + intval*: INTEGER; (* integer value or string length (incl. 0X) *) + realval*: REAL; + + + CONST + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + VAR + ch: SHORTCHAR; (*current character*) + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE Str(VAR sym: BYTE); + VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN; + s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR; + BEGIN i := 0; och := ch; long := FALSE; + LOOP DevCPM.GetL(lch); + IF lch = och THEN EXIT END ; + IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END; + IF lch > 0FFX THEN long := TRUE END; + IF i < LEN(s) - 1 THEN s[i] := lch + ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch + ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch + ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch + END; + INC(i) + END ; + IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0]) + ELSE + sym := string; numtyp := 0; intval := i + 1; NEW(str, intval); + IF long THEN + IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$ + ELSE lstr[i] := 0X + END; + str^ := SHORT(lstr$) + ELSE + IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$); + ELSE lstr[i] := 0X; str^ := SHORT(lstr$) + END; + lstr := NIL + END + END; + DevCPM.Get(ch) + END Str; + + PROCEDURE Identifier(VAR sym: BYTE); + VAR i: SHORTINT; + BEGIN i := 0; + REPEAT + name[i] := ch; INC(i); DevCPM.Get(ch) + UNTIL (ch < "0") + OR ("9" < ch) & (CAP(ch) < "A") + OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À") + OR (ch = "×") + OR (ch = "÷") + OR (i = MaxIdLen); + IF i = MaxIdLen THEN err(240); DEC(i) END ; + name[i] := 0X; sym := ident + END Identifier; + + PROCEDURE Number; + VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL; + dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER; + + PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT; + BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *) + IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0")) + ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10) + ELSE err(2); RETURN 0 + END + END Ord; + + BEGIN (* ("0" <= ch) & (ch <= "9") *) + i := 0; m := 0; n := 0; d := 0; + LOOP (* read mantissa *) + IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN + IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *) + IF n < LEN(dig) THEN dig[n] := ch; INC(n) END; + INC(m) + END; + DevCPM.Get(ch); INC(i) + ELSIF ch = "." THEN DevCPM.Get(ch); + IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT + ELSIF d = 0 THEN (* i > 0 *) d := i + ELSE err(2) + END + ELSE EXIT + END + END; (* 0 <= n <= m <= i, 0 <= d <= i *) + IF d = 0 THEN (* integer *) realval := 0; numtyp := integer; + IF n = m THEN intval := 0; i := 0; + IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char; + IF n <= 4 THEN + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END + ELSE err(203) + END + ELSIF (ch = "H") OR (ch = "S") THEN (* hex 32bit *) + tch := ch; DevCPM.Get(ch); + IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN (* old syntax: hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF n <= 8 THEN + IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END; + IF tch = "S" THEN (* 32 bit hex float *) + r := SYSTEM.VAL(SHORTREAL, intval); + realval := r; intval := 0; numtyp := real32 + END + ELSE err(203) + END + ELSIF ch = "L" THEN (* hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF ch = "R" THEN (* hex float 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END; + a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END; + realval := SYSTEM.VAL(REAL, arr); + intval := 0; numtyp := real64 + ELSE err(203) + END + ELSE (* decimal *) + WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); + a := (MAX(INTEGER) - d) DIV 10; + IF intval > a THEN + a := (intval - a + 65535) DIV 65536 * 65536; + realval := realval + a; intval := intval - a + END; + realval := realval * 10; intval := intval * 10 + d + END; + IF realval = 0 THEN numtyp := integer + ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64 (* 2^63 *) + ELSE intval := 0; err(203) + END + END + ELSE err(203) + END + ELSE (* fraction *) + f := 0; g := 0; e := 0; j := 0; expCh := "E"; + WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END; (* !!! *) + WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END; + IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN + expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE; + IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch) + ELSIF ch = "+" THEN DevCPM.Get(ch) + END; + IF ("0" <= ch) & (ch <= "9") THEN + REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch); + IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n) + ELSE err(203) + END + UNTIL (ch < "0") OR ("9" < ch); + IF neg THEN e := -e END + ELSE err(2) + END + END; + DEC(e, i-d-m); (* decimal point shift *) + IF e < -308 - 16 THEN + realval := 0.0 + ELSIF e < -308 + 14 THEN + realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15 + ELSIF e < j THEN + realval := (f + g) / Math.IntPower(10, j-e) (* Ten(j-e) *) + ELSIF e <= 308 THEN + realval := (f + g) * Math.IntPower(10, e-j) (* Ten(e-j) *) + ELSIF e = 308 + 1 THEN + realval := (f + g) * (Math.IntPower(10, e-j) / 16); + IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16 + ELSE err(203) + END + ELSE err(203) + END; + numtyp := real + END + END Number; + + PROCEDURE Get*(VAR sym: BYTE); + VAR s: BYTE; old: INTEGER; + + PROCEDURE Comment; (* do not read after end of file *) + BEGIN DevCPM.Get(ch); + LOOP + LOOP + WHILE ch = "(" DO DevCPM.Get(ch); + IF ch = "*" THEN Comment END + END ; + IF ch = "*" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN EXIT END ; + DevCPM.Get(ch) + END ; + IF ch = ")" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN err(5); EXIT END + END + END Comment; + + BEGIN + DevCPM.errpos := DevCPM.curpos-1; + WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*) + IF ch = DevCPM.Eot THEN sym := eof; RETURN + ELSE DevCPM.Get(ch) + END + END ; + DevCPM.startpos := DevCPM.curpos - 1; + CASE ch OF (* ch > " " *) + | 22X, 27X : Str(s) + | "#" : s := neq; DevCPM.Get(ch) + | "&" : s := and; DevCPM.Get(ch) + | "(" : DevCPM.Get(ch); + IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; + ELSE s := lparen + END + | ")" : s := rparen; DevCPM.Get(ch) + | "*" : s := times; DevCPM.Get(ch) + | "+" : s := plus; DevCPM.Get(ch) + | "," : s := comma; DevCPM.Get(ch) + | "-" : s := minus; DevCPM.Get(ch) + | "." : DevCPM.Get(ch); + IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END + | "/" : s := slash; DevCPM.Get(ch) + | "0".."9": Number; s := number + | ":" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END + | ";" : s := semicolon; DevCPM.Get(ch) + | "<" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END + | "=" : s := eql; DevCPM.Get(ch) + | ">" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + | "B": Identifier(s); + IF name = "BEGIN" THEN s := begin + ELSIF name = "BY" THEN s := by + END + | "C": Identifier(s); + IF name = "CASE" THEN s := case + ELSIF name = "CONST" THEN s := const + ELSIF name = "CLOSE" THEN s := close + END + | "D": Identifier(s); + IF name = "DO" THEN s := do + ELSIF name = "DIV" THEN s := div + END + | "E": Identifier(s); + IF name = "END" THEN s := end + ELSIF name = "ELSE" THEN s := else + ELSIF name = "ELSIF" THEN s := elsif + ELSIF name = "EXIT" THEN s := exit + END + | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "I": Identifier(s); + IF name = "IF" THEN s := if + ELSIF name = "IN" THEN s := in + ELSIF name = "IS" THEN s := is + ELSIF name = "IMPORT" THEN s := import + END + | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "M": Identifier(s); + IF name = "MOD" THEN s := mod + ELSIF name = "MODULE" THEN s := module + END + | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "O": Identifier(s); + IF name = "OR" THEN s := or + ELSIF name = "OF" THEN s := of + ELSIF name = "OUT" THEN s := out + END + | "P": Identifier(s); + IF name = "PROCEDURE" THEN s := procedure + ELSIF name = "POINTER" THEN s := pointer + END + | "R": Identifier(s); + IF name = "RECORD" THEN s := record + ELSIF name = "REPEAT" THEN s := repeat + ELSIF name = "RETURN" THEN s := return + END + | "T": Identifier(s); + IF name = "THEN" THEN s := then + ELSIF name = "TO" THEN s := to + ELSIF name = "TYPE" THEN s := type + END + | "U": Identifier(s); IF name = "UNTIL" THEN s := until END + | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "W": Identifier(s); + IF name = "WHILE" THEN s := while + ELSIF name = "WITH" THEN s := with + END + | "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_" (* XXX *): Identifier(s) + | "[" : s := lbrak; DevCPM.Get(ch) + | "]" : s := rbrak; DevCPM.Get(ch) + | "^" : s := arrow; DevCPM.Get(ch) + | "$" : s := dollar; DevCPM.Get(ch) + | "{" : s := lbrace; DevCPM.Get(ch); + | "|" : s := bar; DevCPM.Get(ch) + | "}" : s := rbrace; DevCPM.Get(ch) + | "~" : s := not; DevCPM.Get(ch) + | 7FX : s := upto; DevCPM.Get(ch) + ELSE s := null; DevCPM.Get(ch) + END ; + sym := s + END Get; + + PROCEDURE Init*; + BEGIN ch := " " + END Init; + +END DevCPS. \ No newline at end of file diff --git a/Trurl-based/Dev/Mod/CPT.txt b/Trurl-based/Dev/Mod/CPT.txt new file mode 100644 index 0000000..2fdbc03 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPT.txt @@ -0,0 +1,1890 @@ +MODULE DevCPT; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPT.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPM; + + CONST + MaxIdLen = 256; + + TYPE + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; + Const* = POINTER TO ConstDesc; + Object* = POINTER TO ObjDesc; + Struct* = POINTER TO StrDesc; + Node* = POINTER TO NodeDesc; + ConstExt* = String; + LinkList* = POINTER TO LinkDesc; + + ConstDesc* = RECORD + ext*: ConstExt; (* string or code for code proc (longstring in utf8) *) + intval*: INTEGER; (* constant value or adr, proc par size, text position or least case label *) + intval2*: INTEGER; (* string length (#char, incl 0X), proc var size or larger case label *) + setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) + realval*: REAL; (* real or longreal constant value *) + link*: Const (* chain of constants present in obj file *) + END ; + + LinkDesc* = RECORD + offset*, linkadr*: INTEGER; + next*: LinkList; + END; + + ObjDesc* = RECORD + left*, right*, link*, scope*: Object; + name*: String; (* name = null OR name^ # "" *) + leaf*: BOOLEAN; + sysflag*: BYTE; + mode*, mnolev*: BYTE; (* mnolev < 0 -> mno = -mnolev *) + vis*: BYTE; (* internal, external, externalR, inPar, outPar *) + history*: BYTE; (* relevant if name # "" *) + used*, fpdone*: BOOLEAN; + fprint*: INTEGER; + typ*: Struct; (* actual type, changed in with statements *) + ptyp*: Struct; (* original type if typ is changed *) + conval*: Const; + adr*, num*: INTEGER; (* mthno *) + links*: LinkList; + nlink*: Object; (* link for name list, declaration order for methods, library link for imp obj *) + library*, entry*: String; (* library name, entry name *) + modifiers*: POINTER TO ARRAY OF String; (* additional interface strings *) + linkadr*: INTEGER; (* used in ofront *) + red: BOOLEAN; + END ; + + StrDesc* = RECORD + form*, comp*, mno*, extlev*: BYTE; + ref*, sysflag*: SHORTINT; + n*, size*, align*, txtpos*: INTEGER; (* align is alignment for records and len offset for dynarrs *) + untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN; + attribute*: BYTE; + idfp, pbfp*, pvfp*:INTEGER; + BaseTyp*: Struct; + link*, strobj*: Object; + ext*: ConstExt (* id string for interface records *) + END ; + + NodeDesc* = RECORD + left*, right*, link*: Node; + class*, subcl*, hint*: BYTE; + readonly*: BOOLEAN; + typ*: Struct; + obj*: Object; + conval*: Const + END ; + + CONST + maxImps = 127; (* must be <= MAX(SHORTINT) *) + maxStruct = DevCPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) + FirstRef = 32; + FirstRef0 = 16; (* correction for version 0 *) + actVersion = 1; + + VAR + topScope*: Object; + undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*, + real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*, + anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*, + restyp*, iunktyp*, punktyp*, guidtyp*, + intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct; + nofGmod*: BYTE; (*nof imports*) + GlbMod*: ARRAY maxImps OF Object; (* .right = first object, .name = module import name (not alias) *) + SelfName*: Name; (* name of module being compiled *) + SYSimported*: BOOLEAN; + processor*, impProc*: SHORTINT; + libName*: Name; (* library alias of module being compiled *) + null*: String; (* "" *) + + CONST + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + AnyPtr = 14; AnyRec = 15; (* sym file only *) + Char16 = 16; String16 = 17; Int64 = 18; + Res = 20; IUnk = 21; PUnk = 22; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* procedure flags (conval.setval) *) + isHidden = 29; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* sysflags *) + inBit = 2; outBit = 4; interface = 10; + + (* symbol file items *) + Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; + Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; + Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; + Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26; + Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22; + + TYPE + ImpCtxt = RECORD + nextTag, reffp: INTEGER; + nofr, minr, nofm: SHORTINT; + self: BOOLEAN; + ref: ARRAY maxStruct OF Struct; + old: ARRAY maxStruct OF Object; + pvfp: ARRAY maxStruct OF INTEGER; (* set only if old # NIL *) + glbmno: ARRAY maxImps OF BYTE (* index is local mno *) + END ; + + ExpCtxt = RECORD + reffp: INTEGER; + ref: SHORTINT; + nofm: BYTE; + locmno: ARRAY maxImps OF BYTE (* index is global mno *) + END ; + + VAR + universe, syslink, comlink, infinity: Object; + impCtxt: ImpCtxt; + expCtxt: ExpCtxt; + nofhdfld: INTEGER; + sfpresent, symExtended, symNew: BOOLEAN; + version: INTEGER; + symChanges: INTEGER; + portable: BOOLEAN; + depth: INTEGER; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewConst*(): Const; + VAR const: Const; + BEGIN NEW(const); RETURN const + END NewConst; + + PROCEDURE NewObj*(): Object; + VAR obj: Object; + BEGIN NEW(obj); obj.name := null; RETURN obj + END NewObj; + + PROCEDURE NewStr*(form, comp: BYTE): Struct; + VAR typ: Struct; + BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *) + typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ + END NewStr; + + PROCEDURE NewNode*(class: BYTE): Node; + VAR node: Node; + BEGIN + NEW(node); node.class := class; RETURN node + END NewNode; +(* + PROCEDURE NewExt*(): ConstExt; + VAR ext: ConstExt; + BEGIN NEW(ext); RETURN ext + END NewExt; +*) + PROCEDURE NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String; + VAR i: INTEGER; p: String; + BEGIN + i := 0; WHILE name[i] # 0X DO INC(i) END; + IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p + ELSE RETURN null + END + END NewName; + + PROCEDURE OpenScope*(level: BYTE; owner: Object); + VAR head: Object; + BEGIN head := NewObj(); + head.mode := Head; head.mnolev := level; head.link := owner; + IF owner # NIL THEN owner.scope := head END ; + head.left := topScope; head.right := NIL; head.scope := NIL; topScope := head + END OpenScope; + + PROCEDURE CloseScope*; + BEGIN topScope := topScope.left + END CloseScope; + + PROCEDURE Init*(opt: SET); + BEGIN + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + GlbMod[0] := topScope; nofGmod := 1; + sfpresent := TRUE; (* !!! *) + symChanges := 0; + infinity.conval.intval := DevCPM.ConstNotAlloc; + depth := 0 + END Init; + + PROCEDURE Open* (name: Name); + BEGIN + SelfName := name$; topScope.name := NewName(name); + END Open; + + PROCEDURE Close*; + VAR i: SHORTINT; + BEGIN (* garbage collection *) + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END + END Close; + + PROCEDURE SameType* (x, y: Struct): BOOLEAN; + BEGIN + RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp) + END SameType; + + PROCEDURE EqualType* (x, y: Struct): BOOLEAN; + VAR xp, yp: Object; n: INTEGER; + BEGIN + n := 0; + WHILE (n < 100) & (x # y) + & (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag)) + OR ((x.form = Pointer) & (y.form = Pointer)) + OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO + IF x.form = ProcTyp THEN + IF x.sysflag # y.sysflag THEN RETURN FALSE END; + xp := x.link; yp := y.link; + INC(depth); + WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag) + & (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO + xp := xp.link; yp := yp.link + END; + DEC(depth); + IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END + END; + x := x.BaseTyp; y := y.BaseTyp; INC(n) + END; + RETURN SameType(x, y) + END EqualType; + + PROCEDURE Extends* (x, y: Struct): BOOLEAN; + BEGIN + IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END; + IF (x.comp = Record) & (y.comp = Record) THEN + IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END; + WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END + END; + RETURN (x # NIL) & EqualType(x, y) + END Extends; + + PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN; + BEGIN + CASE xform OF + | Char16: RETURN yform IN {Char8, Char16, Int8} + | Int16: RETURN yform IN {Char8, Int8, Int16} + | Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32} + | Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64} + | Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32} + | Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64} + | String16: RETURN yform IN {String8, String16} + ELSE RETURN xform = yform + END + END Includes; + + PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object); + VAR obj: Object; (* i: INTEGER; n: Name; *) + BEGIN obj := mod.scope.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) + IF (obj.mode = Typ) & (obj.vis = internal) THEN obj := NIL + ELSE obj.used := TRUE + END ; + EXIT + END + END ; + res := obj; +(* bh: checks usage of non Unicode WinApi functions and types + IF (res # NIL) & (mod.scope.library # NIL) + & ~(DevCPM.interface IN DevCPM.options) + & (SelfName # "Kernel") & (SelfName # "HostPorts") THEN + n := name + "W"; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(733) + ELSE + i := LEN(name$); + IF name[i - 1] = "A" THEN + n[i - 1] := "W"; n[i] := 0X; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(734) + END + END + END + END; +*) + END FindImport; + + PROCEDURE Find*(VAR name: Name; VAR res: Object); + VAR obj, head: Object; + BEGIN head := topScope; + LOOP obj := head.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (* found, obj.used not set for local objects *) EXIT + END + END ; + IF obj # NIL THEN EXIT END ; + head := head.left; + IF head = NIL THEN EXIT END + END ; + res := obj + END Find; + + PROCEDURE FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + VAR obj: Object; + BEGIN + WHILE (typ # NIL) & (typ # undftyp) DO obj := typ.link; + WHILE obj # NIL DO + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) res := obj; RETURN + END + END ; + typ := typ.BaseTyp + END; + res := NIL + END FindFld; + + PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindField; + + PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ.BaseTyp, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindBaseField; + +(* + PROCEDURE Rotated (y: Object; name: String): Object; + VAR c, gc: Object; + BEGIN + IF name^ < y.name^ THEN + c := y.left; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.left := gc + ELSE + c := y.right; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.right := gc + END; + RETURN gc + END Rotated; + + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR gg, g, p, x: Object; name, sname: String; + BEGIN + sname := scope.name; scope.name := null; + gg := scope; g := gg; p := g; x := p.right; name := obj.name; + WHILE x # NIL DO + IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN + x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); x.red := FALSE + END + END; + gg := g; g := p; p := x; + IF name^ < x.name^ THEN x := x.left + ELSIF name^ > x.name^ THEN x := x.right + ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN + END + END; + x := obj; old := NIL; + IF name^ < p.name^ THEN p.left := x ELSE p.right := x END; + x.red := TRUE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); + x.red := FALSE + END; + scope.right.red := FALSE; scope.name := sname + END InsertIn; +*) + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + ASSERT((scope # NIL) & (scope.mode = Head), 100); + ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name; + WHILE ob1 # NIL DO + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + END; + IF left THEN ob0.left := obj ELSE ob0.right := obj END ; + obj.left := NIL; obj.right := NIL; old := NIL + END InsertIn; + + PROCEDURE Insert* (VAR name: Name; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + obj.mnolev := topScope.mnolev; + InsertIn(obj, topScope, old); + IF old # NIL THEN err(1) END (*double def*) + END Insert; + + PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + IF typ.link = NIL THEN typ.link := obj + ELSE + ob1 := typ.link; name := obj.name; + REPEAT + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + UNTIL ob1 = NIL; + IF left THEN ob0.left := obj ELSE ob0.right := obj END + END + END InsertThisField; + + PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + InsertThisField(obj, typ, old); + IF old # NIL THEN err(1) END (*double def*) + END InsertField; + + +(*-------------------------- Fingerprinting --------------------------*) + + PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X + END FPrintName; + + PROCEDURE ^IdFPrint*(typ: Struct); + + PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object); + (* depends on assignment compatibility of params only *) + BEGIN + IdFPrint(result); DevCPM.FPrint(fp, result.idfp); + WHILE par # NIL DO + DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp); + IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END; (* IN / OUT *) + IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END; + (* par.name and par.adr not considered *) + par := par.link + END + END FPrintSign; + + PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *) + VAR btyp: Struct; strobj: Object; idfp: INTEGER; f, c: SHORTINT; + BEGIN + IF ~typ.idfpdone THEN + typ.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *) + idfp := 0; f := typ.form; c := typ.comp; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c); + btyp := typ.BaseTyp; strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN + FPrintName(idfp, GlbMod[typ.mno].name^); FPrintName(idfp, strobj.name^) + END ; + IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN + IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp) + ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.FPrint(idfp, typ.n) + ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ.link) + END ; + typ.idfp := idfp + END + END IdFPrint; + + PROCEDURE FPrintStr*(typ: Struct); + VAR f, c: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER; + + PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER); (* modifies pvfp only *) + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN FPrintFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld); + IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + DevCPM.FPrint(pvfp, fld.vis); FPrintName(pvfp, fld.name^); DevCPM.FPrint(pvfp, fld.adr); + DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr); + FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.FPrint(pvfp, fld.typ.pvfp) + ELSE FPrintHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END FPrintFlds; + + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + VAR fp: INTEGER; + BEGIN + IF obj # NIL THEN + FPrintTProcs(obj.left); + IF obj.mode = TProc THEN + IF obj.vis # internal THEN + fp := 0; + IF obj.vis = externalR THEN DevCPM.FPrint(fp, externalR) END; + IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, limAttr) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, absAttr) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, empAttr) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, extAttr) + END; + DevCPM.FPrint(fp, TProc); DevCPM.FPrint(fp, obj.num); + FPrintSign(fp, obj.typ, obj.link); FPrintName(fp, obj.name^); + IF obj.entry # NIL THEN FPrintName(fp, obj.entry^) END; + DevCPM.FPrint(pvfp, fp); DevCPM.FPrint(pbfp, fp) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num) + END + END; + FPrintTProcs(obj.right) + END + END FPrintTProcs; + + BEGIN + IF ~typ.fpdone THEN + IdFPrint(typ); pbfp := typ.idfp; + IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END; + IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END; + IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) END; + pvfp := pbfp; typ.pbfp := pbfp; typ.pvfp := pvfp; (* initial fprints may be used recursively *) + typ.fpdone := TRUE; + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF f = Pointer THEN + strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj = NIL) OR (strobj.name = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN + FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp + ELSE (* c = Record *) + IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ; + DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n); + nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE); + FPrintTProcs(typ.link); (* DevCPM.FPrint(pvfp, pbfp); *) strobj := typ.strobj; + IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END + END ; + typ.pbfp := pbfp; typ.pvfp := pvfp + END + END FPrintStr; + + PROCEDURE FPrintObj*(obj: Object); + VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER; + BEGIN + IF ~obj.fpdone THEN + fprint := 0; obj.fpdone := TRUE; + DevCPM.FPrint(fprint, obj.mode); + IF obj.mode = Con THEN + f := obj.typ.form; DevCPM.FPrint(fprint, f); + CASE f OF + | Bool, Char8, Char16, Int8, Int16, Int32: + DevCPM.FPrint(fprint, obj.conval.intval) + | Int64: + x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0)); + r := obj.conval.realval + obj.conval.intval - x * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + DevCPM.FPrint(fprint, SHORT(ENTIER(r))); + DevCPM.FPrint(fprint, x) + | Set: + DevCPM.FPrintSet(fprint, obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval) + | Real64: + DevCPM.FPrintLReal(fprint, obj.conval.realval) + | String8, String16: + FPrintName(fprint, obj.conval.ext^) + | NilTyp: + ELSE err(127) + END + ELSIF obj.mode = Var THEN + DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + ELSIF obj.mode IN {XProc, IProc} THEN + FPrintSign(fprint, obj.typ, obj.link) + ELSIF obj.mode = CProc THEN + FPrintSign(fprint, obj.typ, obj.link); ext := obj.conval.ext; + m := ORD(ext^[0]); f := 1; DevCPM.FPrint(fprint, m); + WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END + ELSIF obj.mode = Typ THEN + FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + END ; + IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END; + IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN + IF obj.library # NIL THEN + FPrintName(fprint, obj.library^) + ELSIF obj.mnolev < 0 THEN + mod := GlbMod[-obj.mnolev]; + IF (mod.library # NIL) THEN + FPrintName(fprint, mod.library^) + END + ELSIF obj.mnolev = 0 THEN + IF libName # "" THEN FPrintName(fprint, libName) END + END; + IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END + END; + obj.fprint := fprint + END + END FPrintObj; + + PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT); (* !!! *) + BEGIN + IF errno = 249 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" "); + DevCPM.LogWStr(GlbMod[-obj.mnolev].name^); + DevCPM.LogW("."); DevCPM.LogWStr(obj.name^); + DevCPM.LogWStr(" is not consistently imported"); + err(249) + ELSIF obj = NIL THEN (* changed module sys flags *) + IF ~symNew & sfpresent THEN + DevCPM.LogWLn; DevCPM.LogWStr(" changed library flag") + END + ELSIF obj.mnolev = 0 THEN (* don't report changes in imported modules *) + IF sfpresent THEN + IF symChanges < 20 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" "); DevCPM.LogWStr(obj.name^); + IF errno = 250 THEN DevCPM.LogWStr(" is no longer in symbol file") + ELSIF errno = 251 THEN DevCPM.LogWStr(" is redefined internally ") + ELSIF errno = 252 THEN DevCPM.LogWStr(" is redefined") + ELSIF errno = 253 THEN DevCPM.LogWStr(" is new in symbol file") + END + ELSIF symChanges = 20 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" ...") + END; + INC(symChanges) + ELSIF (errno = 253) & ~symExtended THEN + DevCPM.LogWLn; + DevCPM.LogWStr(" new symbol file") + END + END; + IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END + END FPrintErr; + +(*-------------------------- Import --------------------------*) + + PROCEDURE InName(VAR name: String); + VAR i: SHORTINT; ch: SHORTCHAR; n: Name; + BEGIN i := 0; + REPEAT + DevCPM.SymRCh(ch); n[i] := ch; INC(i) + UNTIL ch = 0X; + IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END + END InName; + + PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE); (* mno is global *) + VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String; + BEGIN + IF tag = 0 THEN mno := impCtxt.glbmno[0] + ELSIF tag > 0 THEN + lib := NIL; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + ASSERT(tag = Smname); + InName(name); + IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) THEN err(154) END ; + i := 0; + WHILE (i < nofGmod) & (name^ # GlbMod[i].name^) DO INC(i) END ; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head.mode := Head; head.name := name; + mno := nofGmod; head.mnolev := SHORT(SHORT(-mno)); + head.library := lib; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END ; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-tag] + END + END InMod; + + PROCEDURE InConstant(f: INTEGER; conval: Const); + VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name; + BEGIN + CASE f OF + | Byte, Char8, Bool: + DevCPM.SymRCh(ch); conval.intval := ORD(ch) + | Char16: + DevCPM.SymRCh(ch); conval.intval := ORD(ch); + DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256 + | Int8, Int16, Int32: + conval.intval := DevCPM.SymRInt() + | Int64: + DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*); + WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO + x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch) + END; + WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END; + conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s; + conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval)) + | Set: + DevCPM.SymRSet(conval.setval) + | Real32: + DevCPM.SymRReal(rval); conval.realval := rval; + conval.intval := DevCPM.ConstNotAlloc + | Real64: + DevCPM.SymRLReal(conval.realval); + conval.intval := DevCPM.ConstNotAlloc + | String8, String16: + i := 0; + REPEAT + DevCPM.SymRCh(ch); + IF i < LEN(str) - 1 THEN str[i] := ch + ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch + ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch + ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch + END; + INC(i) + UNTIL ch = 0X; + IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END; + conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc; + IF f = String8 THEN conval.intval2 := i + ELSE + i := 0; y := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0; + conval.intval2 := y + END +(* + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc + | String16: + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i); + DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i) + UNTIL (ch = 0X) & (ch1 = 0X); + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc +*) + | NilTyp: + conval.intval := 0 +(* + | Guid: + ext := NewExt(); conval.ext := ext; i := 0; + WHILE i < 16 DO + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + END; + ext[16] := 0X; + conval.intval2 := 16; + conval.intval := DevCPM.ConstNotAlloc; +*) + END + END InConstant; + + PROCEDURE ^InStruct(VAR typ: Struct); + + PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object); + VAR last, new: Object; tag: INTEGER; + BEGIN + InStruct(res); + tag := DevCPM.SymRInt(); last := NIL; + WHILE tag # Send DO + new := NewObj(); new.mnolev := SHORT(SHORT(-mno)); + IF last = NIL THEN par := new ELSE last.link := new END ; + IF tag = Ssys THEN + new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt(); + IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar + ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar + END + END; + IF tag = Svalpar THEN new.mode := Var + ELSE new.mode := VarPar; + IF tag = Sinpar THEN new.vis := inPar + ELSIF tag = Soutpar THEN new.vis := outPar + END + END ; + InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name); + last := new; tag := DevCPM.SymRInt() + END + END InSign; + + PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj.mode := Fld; + IF tag = Srfld THEN obj.vis := externalR ELSE obj.vis := external END ; + InStruct(obj.typ); InName(obj.name); + obj.adr := DevCPM.SymRInt() + ELSE + obj.mode := Fld; + IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName) + ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName); (* !!! *) + obj.sysflag := 1 + ELSIF tag = Ssys THEN + obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())) + ELSE obj.name := NewName(DevCPM.HdProcName) + END; + obj.typ := undftyp; obj.vis := internal; + obj.adr := DevCPM.SymRInt() + END; + RETURN obj + END InFld; + + PROCEDURE InTProc(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); + IF tag = Shdtpro THEN + obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName); + obj.link := NewObj(); (* dummy, easier in Browser *) + obj.typ := undftyp; obj.vis := internal; + obj.num := DevCPM.SymRInt() + ELSE + obj.vis := external; + IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END; + obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1; + IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END; + InSign(mno, obj.typ, obj.link); InName(obj.name); + obj.num := DevCPM.SymRInt(); + IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr) + ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr) + ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr) + ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr) + END + END ; + RETURN obj + END InTProc; + + PROCEDURE InStruct(VAR typ: Struct); + VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String; + t: Struct; obj, last, fld, old, dummy: Object; + BEGIN + tag := DevCPM.SymRInt(); + IF tag # Sstruct THEN + tag := -tag; + IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END; (* correction for new FirstRef *) + typ := impCtxt.ref[tag] + ELSE + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; + tag := DevCPM.SymRInt(); + InMod(tag, mno); InName(name); obj := NewObj(); + IF name = null THEN + IF impCtxt.self THEN old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null + END ; + typ := NewStr(Undef, Basic) + ELSE obj.name := name; InsertIn(obj, GlbMod[mno], old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old.typ.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(Undef, Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old.typ; typ.link := NIL; typ.sysflag := 0; typ.ext := NIL; + typ.fpdone := FALSE; typ.idfpdone := FALSE + END + ELSE typ := NewStr(Undef, Basic) + END + END ; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(ref + maxStruct); + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ.mno := mno; typ.allocated := TRUE; + typ.strobj := obj; obj.mode := Typ; obj.typ := typ; + obj.mnolev := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *) + tag := DevCPM.SymRInt(); + IF tag = Ssys THEN + typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt() + END; + typ.untagged := typ.sysflag > 0; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag = String8 THEN + InName(typ.ext); tag := DevCPM.SymRInt() + END; + CASE tag OF + | Sptr: + typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp) + | Sarr: + typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt(); + typ.size := typ.n * typ.BaseTyp.size (* !!! *) + | Sdarr: + typ.form := Comp; typ.comp := DynArr; InStruct(typ.BaseTyp); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 + ELSE typ.n := 0 + END ; + typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n; (* !!! *) + IF typ.untagged THEN typ.size := DevCPM.PointerSize END + | Srec, Sabsrec, Slimrec, Sextrec: + typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp); + (* correction by ETH 18.1.96 *) + IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END; + typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt(); + typ.n := DevCPM.SymRInt(); + IF tag = Sabsrec THEN typ.attribute := absAttr + ELSIF tag = Slimrec THEN typ.attribute := limAttr + ELSIF tag = Sextrec THEN typ.attribute := extAttr + END; + impCtxt.nextTag := DevCPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) + OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO + fld := InFld(); fld.mnolev := SHORT(SHORT(-mno)); + IF last # NIL THEN last.link := fld END ; + last := fld; + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END ; + WHILE impCtxt.nextTag # Send DO fld := InTProc(mno); + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END + | Spro: + typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link) + | Salias: + InStruct(t); + typ.form := t.form; typ.comp := Basic; typ.size := t.size; + typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE; + typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t + END ; + IF ref = impCtxt.minr THEN + WHILE ref < impCtxt.nofr DO + t := impCtxt.ref[ref]; FPrintStr(t); + obj := t.strobj; (* obj.typ.strobj = obj, else obj.fprint differs (alias) *) + IF obj.name # null THEN FPrintObj(obj) END ; + old := impCtxt.old[ref]; + IF old # NIL THEN t.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old.mnolev < 0 THEN + IF old.history # inconsistent THEN + IF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + END + (* ELSE remain inconsistent *) + END + ELSIF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + ELSIF old.vis = internal THEN old.history := same (* may be changed to "removed" in InObj *) + ELSE old.history := inserted (* may be changed to "same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t.pvfp THEN old.history := inconsistent END ; + IF old.fprint # obj.fprint THEN FPrintErr(old, 249) END + END + ELSIF impCtxt.self THEN obj.history := removed + ELSE obj.history := same + END ; + INC(ref) + END ; + impCtxt.minr := maxStruct + END + END + END InStruct; + + PROCEDURE InObj(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR ch: SHORTCHAR; obj, old: Object; typ: Struct; + tag, i, s: INTEGER; ext: ConstExt; + BEGIN + tag := impCtxt.nextTag; + IF tag = Stype THEN + InStruct(typ); obj := typ.strobj; + IF ~impCtxt.self THEN obj.vis := external END (* type name visible now, obj.fprint already done *) + ELSE + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); obj.vis := external; + IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag >= Sxpro THEN + IF obj.conval = NIL THEN obj.conval := NewConst() END; + obj.conval.intval := -1; + InSign(mno, obj.typ, obj.link); + CASE tag OF + | Sxpro: obj.mode := XProc + | Sipro: obj.mode := IProc + | Scpro: obj.mode := CProc; + s := DevCPM.SymRInt(); + NEW(ext, s + 1); obj.conval.ext := ext; + ext^[0] := SHORT(CHR(s)); i := 1; + WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END + END + ELSIF tag = Salias THEN + obj.mode := Typ; InStruct(obj.typ) + ELSIF (tag = Svar) OR (tag = Srvar) THEN + obj.mode := Var; + IF tag = Srvar THEN obj.vis := externalR END ; + InStruct(obj.typ) + ELSE (* Constant *) + obj.conval := NewConst(); InConstant(tag, obj.conval); + IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END; + obj.mode := Con; obj.typ := impCtxt.ref[tag]; + END ; + InName(obj.name) + END ; + FPrintObj(obj); + IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct) + END ; + IF tag # Stype THEN + InsertIn(obj, GlbMod[mno], old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old.vis = internal THEN old.history := removed + ELSE FPrintObj(old); FPrintStr(old.typ); (* FPrint(obj) already called *) + IF obj.fprint # old.fprint THEN old.history := pbmodified + ELSIF obj.typ.pvfp # old.typ.pvfp THEN old.history := pvmodified + ELSE old.history := same + END + END + ELSE obj.history := removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already inserted in InStruct *) + IF impCtxt.self THEN (* obj.mnolev = 0 *) + IF obj.vis = internal THEN obj.history := removed + ELSIF obj.history = inserted THEN obj.history := same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END ; + RETURN obj + END InObj; + + PROCEDURE Import*(aliasName: Name; VAR name: Name; VAR done: BOOLEAN); + VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String; (* done used in Browser *) + BEGIN + IF name = "SYSTEM" THEN + SYSimported := TRUE; + p := processor; + IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END; + INCL(DevCPM.options, p); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h + ELSIF name = "COM" THEN + IF DevCPM.comAware IN DevCPM.options THEN + INCL(DevCPM.options, DevCPM.com); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h; + ELSE err(151) + END; + ELSIF name = "JAVA" THEN + INCL(DevCPM.options, DevCPM.java) + ELSE + impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + DevCPM.OldSym(name, done); + IF done THEN + lib := NIL; + impProc := SHORT(DevCPM.SymRInt()); + IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END; + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + tag := DevCPM.SymRInt(); + IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt() + ELSE version := 0 + END; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + InMod(tag, mno); + IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN (* symbol file name conflict *) + GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm); + DevCPM.CloseOldSym; done := FALSE + END; + END; + IF done THEN + GlbMod[mno].library := lib; + impCtxt.nextTag := DevCPM.SymRInt(); + WHILE ~DevCPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt() + END ; + Insert(aliasName, obj); + obj.mode := Mod; obj.scope := GlbMod[mno](*.right*); + GlbMod[mno].link := obj; + obj.mnolev := SHORT(SHORT(-mno)); obj.typ := notyp; + DevCPM.CloseOldSym + ELSIF impCtxt.self THEN + sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END + END Import; + +(*-------------------------- Export --------------------------*) + + PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE OutMod(mno: SHORTINT); + VAR mod: Object; + BEGIN + IF expCtxt.locmno[mno] < 0 THEN (* new mod *) + mod := GlbMod[mno]; + IF mod.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(mod.library^) + END; + DevCPM.SymWInt(Smname); + expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm); + OutName(mod.name^) + ELSE DevCPM.SymWInt(-expCtxt.locmno[mno]) + END + END OutMod; + + PROCEDURE ^OutStr(typ: Struct); + PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER); + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN OutFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; OutHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Ssys); (* DevCPM.SymWInt(Shdutptr); *) + IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END; + DevCPM.SymWInt(n); + DevCPM.SymWInt(adr); INC(nofhdfld); + IF n > 1 THEN portable := FALSE END (* hidden untagged pointer are portable *) + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld) + END + END OutHdFld; + + PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ; + OutStr(fld.typ); OutName(fld.name^); DevCPM.SymWInt(fld.adr) + ELSE OutHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END OutFlds; + + PROCEDURE OutSign(result: Struct; par: Object); + BEGIN + OutStr(result); + WHILE par # NIL DO + IF par.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END; + IF par.mode = Var THEN DevCPM.SymWInt(Svalpar) + ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar) + ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar) + ELSE DevCPM.SymWInt(Svarpar) + END ; + OutStr(par.typ); + DevCPM.SymWInt(par.adr); + OutName(par.name^); par := par.link + END ; + DevCPM.SymWInt(Send) + END OutSign; + + PROCEDURE OutTProcs(typ: Struct; obj: Object); + VAR bObj: Object; + BEGIN + IF obj # NIL THEN + IF obj.mode = TProc THEN +(* + IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN + FindBaseField(obj.name^, typ, bObj); + ASSERT((bObj # NIL) & (bObj.num = obj.num)); + IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END + (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) + END; +*) + IF obj.vis # internal THEN + IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END; + IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro) + ELSE DevCPM.SymWInt(Stpro) + END; + OutSign(obj.typ, obj.link); OutName(obj.name^); + DevCPM.SymWInt(obj.num) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.SymWInt(Shdtpro); + DevCPM.SymWInt(obj.num) + END + END; + OutTProcs(typ, obj.left); + OutTProcs(typ, obj.right) + END + END OutTProcs; + + PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *) + VAR strobj: Object; + BEGIN + IF typ.ref < expCtxt.ref THEN DevCPM.SymWInt(-typ.ref) + ELSE + DevCPM.SymWInt(Sstruct); + typ.ref := expCtxt.ref; INC(expCtxt.ref); + IF expCtxt.ref >= maxStruct THEN err(228) END ; + OutMod(typ.mno); strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN OutName(strobj.name^); + CASE strobj.history OF + | pbmodified: FPrintErr(strobj, 252) + | pvmodified: FPrintErr(strobj, 251) + | inconsistent: FPrintErr(strobj, 249) + ELSE (* checked in OutObj or correct indirect export *) + END + ELSE DevCPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) + END; + IF typ.sysflag # 0 THEN (* !!! *) + DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag); + IF typ.sysflag > 0 THEN portable := FALSE END + END; + IF strobj # NIL THEN + IF strobj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE + END; + IF strobj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE + END + END; + IF typ.ext # NIL THEN + DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE + END; + CASE typ.form OF + | Pointer: + DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp) + | ProcTyp: + DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link) + | Comp: + CASE typ.comp OF + | Array: + DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n) + | DynArr: + DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp) + | Record: + IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec) + ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec) + ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec) + ELSE DevCPM.SymWInt(Srec) + END; + IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ; + (* BaseTyp should be Notyp, too late to change *) + DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n); + nofhdfld := 0; OutFlds(typ.link, 0, TRUE); +(* + IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ; (* !!! *) +*) + OutTProcs(typ, typ.link); DevCPM.SymWInt(Send) + END + ELSE (* alias structure *) + DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp) + END + END + END OutStr; + + PROCEDURE OutConstant(obj: Object); + VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL; + BEGIN + f := obj.typ.form; +(* + IF obj.typ = guidtyp THEN f := Guid END; +*) + IF f = Int32 THEN + IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8 + ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16 + END + END; + DevCPM.SymWInt(f); + CASE f OF + | Bool, Char8: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval))) + | Char16: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256))); + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256))) + | Int8, Int16, Int32: + DevCPM.SymWInt(obj.conval.intval) + | Int64: + IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN + a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1 + ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 2097152.0 (*2^21*))); + b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1 + ELSE + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*))); + r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*); + b := SHORT(ENTIER(r / 2097152.0 (*2^21*))); + c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*))) + END; + IF c >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))) + END; + IF b >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))) + END; + DevCPM.SymWInt(a) + | Set: + DevCPM.SymWSet(obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval) + | Real64: + DevCPM.SymWLReal(obj.conval.realval) + | String8, String16: + OutName(obj.conval.ext^) + | NilTyp: +(* + | Guid: + i := 0; + WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END +*) + ELSE err(127) + END + END OutConstant; + + PROCEDURE OutObj(obj: Object); + VAR i, j: SHORTINT; ext: ConstExt; + BEGIN + IF obj # NIL THEN + OutObj(obj.left); + IF obj.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN + IF obj.history = removed THEN FPrintErr(obj, 250) + ELSIF obj.vis # internal THEN + CASE obj.history OF + | inserted: FPrintErr(obj, 253) + | same: (* ok *) + | pbmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END + | pvmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END + END ; + IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END; + IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN + (* name alias for types handled in OutStr *) + IF obj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE + END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END + END; + CASE obj.mode OF + | Con: + OutConstant(obj); OutName(obj.name^) + | Typ: + IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ) + ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^) + END + | Var: + IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ; + OutStr(obj.typ); OutName(obj.name^); + IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN + (* compute fingerprint to avoid structural type equivalence *) + DevCPM.FPrint(expCtxt.reffp, obj.typ.ref) + END + | XProc: + DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | IProc: + DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | CProc: + DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext; + j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j); + WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ; + OutName(obj.name^); portable := FALSE + END + END + END ; + OutObj(obj.right) + END + END OutObj; + + PROCEDURE Export*(VAR ext, new: BOOLEAN); + VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object; oldCSum: INTEGER; + BEGIN + symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; + Import("@self", SelfName, done); nofGmod := nofmod; + oldCSum := DevCPM.checksum; + ASSERT(GlbMod[0].name^ = SelfName); + IF DevCPM.noerr THEN (* ~DevCPM.noerr => ~done *) + DevCPM.NewSym(SelfName); + IF DevCPM.noerr THEN + DevCPM.SymWInt(0); (* portable symfile *) + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + DevCPM.SymWInt(actVersion); + old := GlbMod[0]; portable := TRUE; + IF libName # "" THEN + DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE; + IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN + FPrintErr(NIL, 252) + END + ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252) + END; + DevCPM.SymWInt(Smname); OutName(SelfName); + expCtxt.reffp := 0; expCtxt.ref := FirstRef; + expCtxt.nofm := 1; expCtxt.locmno[0] := 0; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; + OutObj(topScope.right); + ext := sfpresent & symExtended; + new := ~sfpresent OR symNew OR (DevCPM.checksum # oldCSum); + IF DevCPM.noerr & ~portable THEN + DevCPM.SymReset; + DevCPM.SymWInt(processor) (* nonportable symfile *) + END; + IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN + new := TRUE + END ; + IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END + (* DevCPM.RegisterNewSym is called in OP2 after writing the object file *) + END + END + END Export; (* no new symbol file if ~DevCPM.noerr *) + + + PROCEDURE InitStruct(VAR typ: Struct; form: BYTE); + BEGIN + typ := NewStr(form, Basic); typ.ref := form; typ.size := 1; typ.allocated := TRUE; + typ.strobj := NewObj(); typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE + END InitStruct; + + PROCEDURE EnterBoolConst(name: Name; val: INTEGER); + VAR obj: Object; + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val + END EnterBoolConst; + + PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object); + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val + END EnterRealConst; + + PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; VAR res: Struct); + VAR obj: Object; typ: Struct; + BEGIN + Insert(name, obj); + typ := NewStr(form, Basic); obj.mode := Typ; obj.typ := typ; obj.vis := external; + typ.strobj := obj; typ.size := size; typ.ref := form; typ.allocated := TRUE; + typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE; res := typ + END EnterTyp; + + PROCEDURE EnterProc(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := SProc; obj.typ := notyp; obj.adr := num + END EnterProc; + + PROCEDURE EnterAttr(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := Attr; obj.adr := num + END EnterAttr; + + PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT); + VAR obj, par: Object; + BEGIN + InsertField(name, rec, obj); + obj.mnolev := -128; (* for correct implement only behaviour *) + obj.mode := TProc; obj.num := num; obj.conval := NewConst(); + obj.conval.setval := obj.conval.setval + {newAttr}; + IF typ = 0 THEN (* FINALIZE, RELEASE *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, empAttr) + ELSIF typ = 1 THEN (* QueryInterface *) + par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar; + par.sysflag := 8; par.adr := 16; par.typ := punktyp; + par.link := obj.link; obj.link := par; + par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar; + par.sysflag := 16; par.adr := 12; par.typ := guidtyp; + par.link := obj.link; obj.link := par; + obj.typ := restyp; obj.vis := external; + INCL(obj.conval.setval, extAttr) + ELSIF typ = 2 THEN (* AddRef, Release *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, isHidden); + INCL(obj.conval.setval, extAttr) + END; + par := NewObj(); par.name := NewName("this"); par.mode := Var; + par.adr := 8; par.typ := ptr; + par.link := obj.link; obj.link := par; + END EnterTProc; + + PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT); + VAR obj: Object; + BEGIN + obj := NewObj(); obj.mode := Fld; + obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs; + obj.link := root; root := obj + END EnterHdField; + +BEGIN + NEW(null, 1); null^ := ""; + topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0; + InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp); + InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize; + InitStruct(string16typ, String16); + undftyp.BaseTyp := undftyp; + + (*initialization of module SYSTEM*) +(* + EnterTyp("BYTE", Byte, 1, bytetyp); + EnterProc("NEW", sysnewfn); +*) + EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp); + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); + EnterProc("CC", ccfn); + EnterProc("LSH", lshfn); + EnterProc("ROT", rotfn); + EnterProc("GET", getfn); + EnterProc("PUT", putfn); + EnterProc("GETREG", getrfn); + EnterProc("PUTREG", putrfn); + EnterProc("BIT", bitfn); + EnterProc("VAL", valfn); + EnterProc("MOVE", movefn); + EnterProc("THISRECORD", thisrecfn); + EnterProc("THISARRAY", thisarrfn); + syslink := topScope.right; topScope.right := NIL; + + (* initialization of module COM *) + EnterProc("ID", iidfn); + EnterProc("QUERY", queryfn); + EnterTyp("RESULT", Int32, 4, restyp); + restyp.ref := Res; + EnterTyp("GUID", Guid, 16, guidtyp); + guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16; + EnterTyp("IUnknown^", IUnk, 12, iunktyp); + iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3; + iunktyp.attribute := absAttr; +(* + EnterHdField(iunktyp.link, 12); +*) + iunktyp.BaseTyp := NIL; iunktyp.align := 4; + iunktyp.sysflag := interface; iunktyp.untagged := TRUE; + NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}"; + EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp); + punktyp.form := Pointer; punktyp.BaseTyp := iunktyp; + punktyp.sysflag := interface; punktyp.untagged := TRUE; + EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1); + EnterTProc(punktyp, iunktyp, "AddRef", 1, 2); + EnterTProc(punktyp, iunktyp, "Release", 2, 2); + comlink := topScope.right; topScope.right := NIL; + + universe := topScope; + EnterProc("LCHR", lchrfn); + EnterProc("LENTIER", lentierfcn); + EnterTyp("ANYREC", AnyRec, 0, anytyp); + anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1; + anytyp.BaseTyp := NIL; anytyp.extlev := -1; (* !!! *) + anytyp.attribute := absAttr; + EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp); + anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp; + EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0); + EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0); + EnterProc("VALID", validfn); + + EnterTyp("SHORTCHAR", Char8, 1, char8typ); + string8typ.BaseTyp := char8typ; + EnterTyp("CHAR", Char16, 2, char16typ); + EnterTyp("LONGCHAR", Char16, 2, lchar16typ); + string16typ.BaseTyp := char16typ; + EnterTyp("SET", Set, 4, settyp); + EnterTyp("BYTE", Int8, 1, int8typ); + guidtyp.BaseTyp := int8typ; + EnterTyp("SHORTINT", Int16, 2, int16typ); + EnterTyp("INTEGER", Int32, 4, int32typ); + EnterTyp("LONGINT", Int64, 8, int64typ); + EnterTyp("LARGEINT", Int64, 8, lint64typ); + EnterTyp("SHORTREAL", Real32, 4, real32typ); + EnterTyp("REAL", Real64, 8, real64typ); + EnterTyp("LONGREAL", Real64, 8, lreal64typ); + EnterTyp("BOOLEAN", Bool, 1, booltyp); + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) + EnterBoolConst("TRUE", 1); + EnterRealConst("INF", DevCPM.InfReal, infinity); + EnterProc("HALT", haltfn); + EnterProc("NEW", newfn); + EnterProc("ABS", absfn); + EnterProc("CAP", capfn); + EnterProc("ORD", ordfn); + EnterProc("ENTIER", entierfn); + EnterProc("ODD", oddfn); + EnterProc("MIN", minfn); + EnterProc("MAX", maxfn); + EnterProc("CHR", chrfn); + EnterProc("SHORT", shortfn); + EnterProc("LONG", longfn); + EnterProc("SIZE", sizefn); + EnterProc("INC", incfn); + EnterProc("DEC", decfn); + EnterProc("INCL", inclfn); + EnterProc("EXCL", exclfn); + EnterProc("LEN", lenfn); + EnterProc("COPY", copyfn); + EnterProc("ASH", ashfn); + EnterProc("ASSERT", assertfn); +(* + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); +*) + EnterProc("BITS", bitsfn); + EnterAttr("ABSTRACT", absAttr); + EnterAttr("LIMITED", limAttr); + EnterAttr("EMPTY", empAttr); + EnterAttr("EXTENSIBLE", extAttr); + NEW(intrealtyp); intrealtyp^ := real64typ^; + impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; + impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char8] := char8typ; + impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; + impCtxt.ref[Int32] := int32typ; impCtxt.ref[Real32] := real32typ; + impCtxt.ref[Real64] := real64typ; impCtxt.ref[Set] := settyp; + impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp; + impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp; + impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp; + impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ; + impCtxt.ref[Int64] := int64typ; + impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp; + impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp; +END DevCPT. + +Objects: + + mode | adr conval link scope leaf + ------------------------------------------------ + Undef | Not used + Var | vadr next regopt Glob or loc var or proc value parameter + VarPar| vadr next regopt Var parameter (vis = 0 | inPar | outPar) + Con | val Constant + Fld | off next Record field + Typ | Named type + LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end + XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end + SProc | fno sizes Standard procedure + CProc | code firstpar scope Code procedure + IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end + Mod | scope Module + Head | txtpos owner firstvar Scope anchor + TProc | entry sizes firstpar scope leaf Bound procedure, mthno = obj.num + + Structures: + + form comp | n BaseTyp link mno txtpos sysflag + ---------------------------------------------------------------------------------- + Undef Basic | + Byte Basic | + Bool Basic | + Char8 Basic | + Int8 Basic | + Int16 Basic | + Int32 Basic | + Real32 Basic | + Real64 Basic | + Set Basic | + String8 Basic | + NilTyp Basic | + NoTyp Basic | + Pointer Basic | PBaseTyp mno txtpos sysflag + ProcTyp Basic | ResTyp params mno txtpos sysflag + Comp Array | nofel ElemTyp mno txtpos sysflag + Comp DynArr| dim ElemTyp mno txtpos sysflag + Comp Record| nofmth RBaseTyp fields mno txtpos sysflag + Char16 Basic | + String16Basic | + Int64 Basic | + +Nodes: + +design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc. +expr = design|Nconst|Nupto|Nmop|Ndop|Ncall. +nextexpr = NIL|expr. +ifstat = NIL|Nif. +casestat = Ncaselse. +sglcase = NIL|Ncasedo. +stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat| + Nloop|Nexit|Nreturn|Nwith|Ntrap. + + + class subcl obj left right link + --------------------------------------------------------- + +design Nvar var nextexpr + Nvarpar varpar nextexpr + Nfield field design nextexpr + Nderef ptr/str design nextexpr + Nindex design expr nextexpr + Nguard design nextexpr (typ = guard type) + Neguard design nextexpr (typ = guard type) + Ntype type nextexpr + Nproc normal proc nextexpr + super proc nextexpr + + +expr design + Nconst const (val = node.conval) + Nupto expr expr nextexpr + Nmop not expr nextexpr + minus expr nextexpr + is tsttype expr nextexpr + conv expr nextexpr + abs expr nextexpr + cap expr nextexpr + odd expr nextexpr + bit expr nextexpr {x} + adr expr nextexpr SYSTEM.ADR + typ expr nextexpr SYSTEM.TYP + cc Nconst nextexpr SYSTEM.CC + val expr nextexpr SYSTEM.VAL + Ndop times expr expr nextexpr + slash expr expr nextexpr + div expr expr nextexpr + mod expr expr nextexpr + and expr expr nextexpr + plus expr expr nextexpr + minus expr expr nextexpr + or expr expr nextexpr + eql expr expr nextexpr + neq expr expr nextexpr + lss expr expr nextexpr + leq expr expr nextexpr + grt expr expr nextexpr + geq expr expr nextexpr + in expr expr nextexpr + ash expr expr nextexpr + msk expr Nconst nextexpr + len design Nconst nextexpr + min expr expr nextexpr MIN + max expr expr nextexpr MAX + bit expr expr nextexpr SYSTEM.BIT + lsh expr expr nextexpr SYSTEM.LSH + rot expr expr nextexpr SYSTEM.ROT + Ncall fpar design nextexpr nextexpr + Ncomp stat expr nextexpr + +nextexpr NIL + expr + +ifstat NIL + Nif expr stat ifstat + +casestat Ncaselse sglcase stat (minmax = node.conval) + +sglcase NIL + Ncasedo Nconst stat sglcase + +stat NIL + Ninittd stat (of node.typ) + Nenter proc stat stat stat (proc=NIL for mod) + Nassign assign design expr stat + newfn design nextexp stat + incfn design expr stat + decfn design expr stat + inclfn design expr stat + exclfn design expr stat + copyfn design expr stat + getfn design expr stat SYSTEM.GET + putfn expr expr stat SYSTEM.PUT + getrfn design Nconst stat SYSTEM.GETREG + putrfn Nconst expr stat SYSTEM.PUTREG + sysnewfn design expr stat SYSTEM.NEW + movefn expr expr stat SYSTEM.MOVE + (right.link = 3rd par) + Ncall fpar design nextexpr stat + Nifelse ifstat stat stat + Ncase expr casestat stat + Nwhile expr stat stat + Nrepeat stat expr stat + Nloop stat stat + Nexit stat + Nreturn proc nextexpr stat (proc = NIL for mod) + Nwith ifstat stat stat + Ntrap expr stat + Ncomp stat stat stat diff --git a/Trurl-based/Dev/Mod/CPV486.txt b/Trurl-based/Dev/Mod/CPV486.txt new file mode 100644 index 0000000..96851ea --- /dev/null +++ b/Trurl-based/Dev/Mod/CPV486.txt @@ -0,0 +1,1774 @@ +MODULE DevCPV486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPV486.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPH, DevCPL486, DevCPC486; + + CONST + processor* = 10; (* for i386 *) + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + + (*SYSTEM function number*) + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* COM function number *) + validfn = 40; queryfn = 42; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24; + wreg = {AX, BX, CX, DX, SI, DI}; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* sysflag *) + untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7; + interface = 10; guarded = 8; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + ParOff = 8; + interfaceSize = 16; (* SIZE(Kernel.Interface) *) + addRefFP = 4E27A847H; (* fingerprint of AddRef and Release procedures *) + intHandlerFP = 24B0EAE3H; (* fingerprint of InterfaceTrapHandler *) + numPreIntProc = 2; + + + VAR + Exit, Return: DevCPL486.Label; + assert, sequential: BOOLEAN; + nesting, actual: INTEGER; + query, addRef, release, release2: DevCPT.Object; + + PROCEDURE Init*(opt: SET); + CONST ass = 2; + BEGIN + DevCPL486.Init(opt); DevCPC486.Init(opt); + assert := ass IN opt; + DevCPM.breakpc := MAX(INTEGER); + query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL; + END Init; + + PROCEDURE Close*; + BEGIN + DevCPL486.Close + END Close; + + PROCEDURE Align(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: INC(offset, offset MOD 2) + | 4: INC(offset, (-offset) MOD 4) + | 8: INC(offset, (-offset) MOD 8) + END + END Align; + + PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: DEC(offset, offset MOD 2) + | 4: DEC(offset, offset MOD 4) + | 8: DEC(offset, offset MOD 8) + END + END NegAlign; + + PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER; (* typ.comp # DynArr *) + VAR align: INTEGER; + BEGIN + WHILE typ.comp = Array DO typ := typ.BaseTyp END ; + IF typ.comp = Record THEN + align := typ.align + ELSE + align := typ.size; + END; + IF align > limit THEN RETURN limit ELSE RETURN align END + END Base; + +(* ----------------------------------------------------- + reference implementation of TypeSize for portable symbol files + mandatory for all non-system structures + + PROCEDURE TypeSize (typ: DevCPT.Struct); + VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; TypeSize(btyp); + IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4) + ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2) + END; + fld.adr := offset; INC(offset, btyp.size); + fld := fld.link + END; + IF offset > 2 THEN INC(offset, (-offset) MOD 4) END; + typ.size := offset; typ.align := 4; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + TypeSize(btyp); + typ.size := typ.n * btyp.size + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + TypeSize(btyp); + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END TypeSize; + +----------------------------------------------------- *) + + PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN); + VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER; + fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name; + BEGIN + IF typ.untagged THEN guarded := TRUE END; + IF typ = DevCPT.undftyp THEN DevCPM.err(58) + ELSIF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0; align := 1; + ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align + END ; + IF typ.sysflag = noAlign THEN alignLimit := 1 + ELSIF typ.sysflag = align2 THEN alignLimit := 2 + ELSIF typ.sysflag = align8 THEN alignLimit := 8 + ELSE alignLimit := 4 + END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; GTypeSize(btyp, guarded); + IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit) + ELSIF btyp.size >= 4 THEN falign := 4 + ELSIF btyp.size >= 2 THEN falign := 2 + ELSE falign := 1 + END; + IF typ.sysflag = union THEN + fld.adr := 0; + IF btyp.size > offset THEN offset := btyp.size END; + ELSE + Align(offset, falign); + fld.adr := offset; + IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size) + ELSE offset := 4; DevCPM.Mark(214, typ.txtpos) + END + END; + IF falign > align THEN align := falign END ; + fld := fld.link + END; +(* + IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 8; + fld.right := typ.link; typ.link := fld; + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 12; + typ.link.link := fld; typ.link.left := fld; + offset := interfaceSize; align := 4 + END; +*) + IF typ.sysflag <= 0 THEN align := 4 END; + typ.align := align; + IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END; + typ.size := offset; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + GTypeSize(btyp, guarded); + IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size + ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos) + END + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize; + IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + GTypeSize(btyp, guarded); + IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4 + ELSE + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END + END GTypeSize; + + PROCEDURE TypeSize*(typ: DevCPT.Struct); (* also called from DevCPT.InStruct for arrays *) + BEGIN + GTypeSize(typ, FALSE) + END TypeSize; + + PROCEDURE GetComKernel; + VAR name: DevCPT.Name; mod: DevCPT.Object; + BEGIN + IF addRef = NIL THEN + DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL); + DevCPT.topScope.name := DevCPT.NewName("$$"); + name := "AddRef"; DevCPT.Insert(name, addRef); + addRef.mode := XProc; + addRef.fprint := addRefFP; + addRef.fpdone := TRUE; + name := "Release"; DevCPT.Insert(name, release); + release.mode := XProc; + release.fprint := addRefFP; + release.fpdone := TRUE; + name := "Release2"; DevCPT.Insert(name, release2); + release2.mode := XProc; + release2.fprint := addRefFP; + release2.fpdone := TRUE; + name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler); + DevCPC486.intHandler.mode := XProc; + DevCPC486.intHandler.fprint := intHandlerFP; + DevCPC486.intHandler.fpdone := TRUE; + DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope; + INC(DevCPT.nofGmod); + DevCPT.CloseScope; + END + END GetComKernel; + + PROCEDURE EnumTProcs(rec: DevCPT.Struct); (* method numbers in declaration order *) + VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object; + BEGIN + IF rec.n = -1 THEN + rec.n := 0; btyp := rec.BaseTyp; + IF btyp # NIL THEN + EnumTProcs(btyp); rec.n := btyp.n; + END; + obj := rec.strobj.link; + WHILE obj # NIL DO + DevCPT.FindBaseField(obj.name^, rec, redef); + IF redef # NIL THEN obj.num := redef.num (*mthno*); + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END; + obj := obj.nlink + END + END + END EnumTProcs; + + PROCEDURE CountTProcs(rec: DevCPT.Struct); + VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name; + + PROCEDURE TProcs(obj: DevCPT.Object); (* obj.mnolev = 0, TProcs of base type already counted *) + VAR redef: DevCPT.Object; + BEGIN + IF obj # NIL THEN + TProcs(obj.left); + IF obj.mode = TProc THEN + DevCPT.FindBaseField(obj.name^, rec, redef); + (* obj.adr := 0 *) + IF redef # NIL THEN + obj.num := redef.num (*mthno*); + IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN + obj.num := numPreIntProc + comProc - 1 - obj.num + END; + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END + END ; + TProcs(obj.right) + END + END TProcs; + + BEGIN + IF rec.n = -1 THEN + comProc := 0; + IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END; + btyp := rec.BaseTyp; + IF btyp # NIL THEN + IF btyp.sysflag = interface THEN + EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n; + ELSE + CountTProcs(btyp); rec.n := btyp.n + END + END; + WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END; + IF (btyp # NIL) & (btyp.sysflag = interface) THEN + IF comProc > 0 THEN + name := "QueryInterface"; DevCPT.FindField(name, rec, m); + IF m.link.typ.sysflag = interface THEN + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr}; + m.nlink := query; query := m + END; + name := "AddRef"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef; + END; + name := "RELEASE"; + DevCPT.FindField(name, rec, rel); + IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END; + IF (comProc > 0) OR (rel # NIL) THEN + name := "Release"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; m.adr := -1; + IF rel # NIL THEN release2.used := TRUE; m.nlink := release2 + ELSE release.used := TRUE; m.nlink := release + END + END + END; + TProcs(rec.link); + END + END CountTProcs; + + PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object); + + PROCEDURE ^TProcedures(obj: DevCPT.Object); + + PROCEDURE TypeAlloc(typ: DevCPT.Struct); + VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF ~typ.allocated THEN (* not imported, not predefined, not allocated yet *) + typ.allocated := TRUE; + TypeSize(typ); + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF typ.sysflag = interface THEN + EnumTProcs(typ); + ELSE + CountTProcs(typ) + END; + IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END; + IF btyp # NIL THEN TypeAlloc(btyp) END; + IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + TypeAlloc(fld.typ); fld := fld.link + END; + TProcedures(typ.link) + ELSIF f = Pointer THEN + IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos) + ELSE TypeAlloc(btyp); + END + ELSIF f = ProcTyp THEN + TypeAlloc(btyp); + Parameters(typ.link, NIL) + ELSE (* c IN {Array, DynArr} *) + TypeAlloc(btyp); + IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END; + END + END + END TypeAlloc; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE Parameters(firstPar, proc: DevCPT.Object); + (* firstPar.mnolev = 0 *) + VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER; + BEGIN + padr := ParOff; par := firstPar; + WHILE par # NIL DO + typ := par.typ; TypeAlloc(typ); + par.adr := padr; + IF (par.mode = VarPar) & (typ.comp # DynArr) THEN + IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8) + ELSE INC(padr, 4) + END + ELSE + IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END; + INC(padr, typ.size); Align(padr, 4) + END; + par := par.link + END; + IF proc # NIL THEN + IF proc.mode = XProc THEN + INCL(proc.conval.setval, isCallback) + ELSIF (proc.mode = TProc) + & (proc.num >= numPreIntProc) + & (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ)) + THEN + INCL(proc.conval.setval, isCallback); + INCL(proc.conval.setval, isGuarded) + END; + IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END; + IF isGuarded IN proc.conval.setval THEN + GetComKernel; vadr := -24 + ELSE + vadr := 0; + IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END; + IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END + END; + proc.conval.intval := padr; proc.conval.intval2 := vadr; + END + END Parameters; + + PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER); + (* allocates only offsets, regs allocated in DevCPC486.Enter *) + VAR adr: INTEGER; typ: DevCPT.Struct; + BEGIN + adr := varSize; + WHILE var # NIL DO + typ := var.typ; TypeAlloc(typ); + DEC(adr, typ.size); NegAlign(adr, Base(typ, 4)); + var.adr := adr; + var := var.link + END; + NegAlign(adr, 4); varSize := adr + END Variables; + + PROCEDURE ^Objects(obj: DevCPT.Object); + + PROCEDURE Procedure(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR oldPos: INTEGER; + BEGIN + oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr; + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ; + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + DevCPM.errpos := oldPos + END Procedure; + + PROCEDURE TProcedures(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR par: DevCPT.Object; psize: INTEGER; + BEGIN + IF obj # NIL THEN + TProcedures(obj.left); + IF (obj.mode = TProc) & (obj.scope # NIL) THEN + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + END ; + TProcedures(obj.right) + END + END TProcedures; + + PROCEDURE Objects(obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + Objects(obj.left); + IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN + IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ); + ELSE Procedure(obj) + END + END ; + Objects(obj.right) + END + END Objects; + + PROCEDURE Allocate*; + VAR gvarSize: INTEGER; name: DevCPT.Name; + BEGIN + DevCPM.errpos := DevCPT.topScope.adr; (* text position of scope used if error *) + gvarSize := 0; + Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize; + Objects(DevCPT.topScope.right) + END Allocate; + + (************************) + + PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN; + BEGIN + WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO + CASE n1.class OF + | Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj + | Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval) + | Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END + | Nderef, Nguard: + | Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + | Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END + | Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + ELSE RETURN FALSE + END ; + n1 := n1.left; n2 := n2.left + END; + RETURN FALSE + END SameExp; + + PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER); + VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE; + BEGIN + used := {}; size := 0; + WHILE n # NIL DO + IF n.class # Ncomp THEN + Check(n.left, ux, sx); + Check(n.right, uy, sy) + END; + ux := ux + uy; sf := 0; + CASE n.class OF + | Nvar, Nvarpar: + IF (n.class = Nvarpar) OR (n.typ.comp = DynArr) OR + (n.obj.mnolev > 0) & + (DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END + | Nguard: sf := 2 + | Neguard, Nderef: sf := 1 + | Nindex: + IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END; + IF sx > 0 THEN INC(sy) END + | Nmop: + CASE n.subcl OF + | is, adr, typfn, minus, abs, cap, val: sf := 1 + | bit: sf := 2; INCL(ux, CX) + | conv: + IF n.typ.form = Int64 THEN sf := 2 + ELSIF ~(n.typ.form IN realSet) THEN sf := 1; + IF n.left.typ.form IN realSet THEN INCL(ux, AX) END + END + | odd, cc, not: + END + | Ndop: + f := n.left.typ.form; + IF f # Bool THEN + CASE n.subcl OF + | times: + sf := 1; + IF f = Int8 THEN INCL(ux, AX) END + | div, mod: + sf := 3; INCL(ux, AX); + IF f > Int8 THEN INCL(ux, DX) END + | eql..geq: + IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4 + ELSIF f IN realSet THEN INCL(ux, AX); sf := 1 + ELSE sf := 1 + END + | ash, lsh, rot: + IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END + | slash, plus, minus, msk, in, bit: + sf := 1 + | len: + IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3 + ELSE sf := 1 + END + | min, max: + sf := 1; + IF f IN realSet THEN INCL(ux, AX) END + | queryfn: + ux := ux + {CX, SI, DI}; sf := 4 + END; + IF sy > sx THEN INC(sx) ELSE INC(sy) END + END + | Nupto: + IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2 + ELSE sf := 3 + END; + INCL(ux, CX); INC(sx) + | Ncall, Ncomp: + sf := 10; ux := wreg + {float} + | Nfield, Nconst, Nproc, Ntype: + END; + used := used + ux; + IF sx > size THEN size := sx END; + IF sy > size THEN size := sy END; + IF sf > size THEN size := sf END; + n := n.link + END; + IF size > 10 THEN size := 10 END + END Check; + + PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET); + VAR ux, uy: SET; sx, sy: INTEGER; + BEGIN + Check(left, ux, sx); Check(right, uy, sy); + IF sy > sx THEN + expr(right, y, hy + stpy, ux + stpy * {AX, CX}); + expr(left, x, hx, stpx); + DevCPC486.Assert(y, hy, stpy) + ELSE + expr(left, x, hx + stpx, uy); + expr(right, y, hy, stpy); + DevCPC486.Assert(x, hx, stpx) + END; + END DualExp; + + PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET); + VAR y: DevCPL486.Item; rev: BOOLEAN; + BEGIN + DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk}); + IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN + DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSIF x.mode # Reg THEN + DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF y.mode # Reg THEN + DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END IntDOp; + + PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER; + BEGIN + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END; + IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN + expr(n.right, x, {}, ux + {mem, stk}); + expr(n.left, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSIF float IN uy THEN (* function calls in both operands *) + expr(n.left, y, {}, uy + {mem}); + expr(n.right, x, {}, {mem, stk}); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSE + expr(n.left, x, {}, uy + {mem, stk}); + expr(n.right, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, FALSE) + END + END FloatDOp; + + PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER; + BEGIN + CASE n.class OF + Nvar, Nvarpar: + obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0; + IF obj.typ.comp = DynArr THEN x.mode := VarPar END; + IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con + ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con + ELSE x.offset := 0; x.tmode := VarPar + END + | Nfield: + design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj) + | Nderef: + IF n.subcl # 0 THEN + expr(n.left, x, hint, stop); + IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END + ELSE + expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x) + END + | Nindex: + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF wreg - uy = {} THEN + expr(n.right, y, hint + stop, ux); + design(n.left, x, hint, stop); + IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END + ELSE + design(n.left, x, hint, stop + uy); + IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {}) + ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop) + END + END + | Nguard, Neguard: + IF n.typ.form = Pointer THEN + IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END + ELSE design(n.left, x, hint, stop) + END; + DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard) + | Nproc: + obj := n.obj; x.mode := obj.mode; x.obj := obj; + IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END + END; + x.typ := n.typ + END design; + + PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN; + BEGIN + IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN + WHILE x.class = Nindex DO x := x.left END; + IF x.class = Nderef THEN RETURN TRUE END + END; + RETURN FALSE + END IsAllocDynArr; + + PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN); + VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER; + BEGIN + Check(left, ux, sx); + expr(right, y, wreg - {SI} + ux, {}); + ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux); + IF useLen & IsAllocDynArr(left) THEN (* keep len descriptor *) + design(left, x, wreg - {CX}, {loaded}); + DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI}) + ELSE + expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con}); + DevCPC486.Load(ay, {}, wreg - {SI} + {con}); + DevCPC486.Free(ax); DevCPC486.Free(ay) + END StringOp; + + PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + BEGIN + IF n.class < Nconst THEN + design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop) + ELSE expr(n, x, hint, stop) + END + END AdrExpr; + + (* ---------- interface pointer reference counting ---------- *) + + PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN); + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN + IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN + IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END + ELSE FindPtrs(fld.typ, fld.adr + adr) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF DevCPC486.ContainsIPtrs(btyp) THEN + i := 0; + WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END + END + ELSIF typ.comp = DynArr THEN + IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END + END + END FindPtrs; + + BEGIN + FindPtrs(typ, 0) + END HandleIPtrs; + + PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface) + & ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall)) + END CountedPtr; + + PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET); + (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + BEGIN + expr(ny, y, {}, wreg - {SI} + {mem, stk}); + IF (ny.class # Nconst) & ~CountedPtr(ny) THEN + DevCPC486.IPAddRef(y, 0, TRUE) + END; + IF nx # NIL THEN + DevCPC486.Assert(y, {}, wreg - {SI} + ux); + expr(nx, x, wreg - {DI}, {loaded}); + IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN + DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0 + END; + DevCPC486.IPRelease(x, 0, TRUE, FALSE); + END + END IPAssign; + + PROCEDURE IPStructAssign (typ: DevCPT.Struct); + VAR x, y: DevCPL486.Item; + BEGIN + IF typ.comp = DynArr THEN DevCPM.err(270) END; + (* addresses in SI and DI *) + x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0; + y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0; + HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE) + END IPStructAssign; + + PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item); + BEGIN + expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0; + IF nx.typ.form = Comp THEN + HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE) + ELSE (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + END + END IPFree; + + (* unchanged val parameters allways counted because of aliasing problems REMOVED! *) + + PROCEDURE InitializeIPVars (proc: DevCPT.Object); + VAR x: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* changed value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE) + END; + obj := obj.link + END + END InitializeIPVars; + + PROCEDURE ReleaseIPVars (proc: DevCPT.Object); + VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + obj := proc.link; + WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO + obj := obj.link + END; + IF obj = NIL THEN + obj := proc.scope.scope; + WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END; + IF obj = NIL THEN RETURN END + END; + DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32); + DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32); + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE) + END; + obj := obj.link + END; + obj := proc.scope.scope; + WHILE obj # NIL DO (* local variables *) + IF obj.used THEN + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE); + END; + obj := obj.link + END; + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END + END ReleaseIPVars; + + PROCEDURE CompareIntTypes ( + typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER + ); + VAR x, y: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + local := DevCPL486.NewLbl; + typ := typ.BaseTyp; num := 0; + WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO + IF (typ.sysflag = interface) & (typ.ext # NIL) THEN + IF num > 0 THEN DevCPC486.JumpT(x, local) END; + DevCPC486.GuidFromString(typ.ext, y); + x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem}); + x := y; DevCPC486.GetAdr(x, wreg - {DI}, {}); + x := id; DevCPC486.CmpString(x, y, eql, FALSE); + INC(num) + END; + typ := typ.BaseTyp + END; + IF num > 0 THEN DevCPC486.JumpF(x, exit) END; + IF num > 1 THEN DevCPL486.SetLabel(local) END + END CompareIntTypes; + + PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object); + VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER; + BEGIN + nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl; + this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp; + id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer; + int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer; + DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0; + DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c); + unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp; + DevCPC486.Load(unk, {}, {}); + unk.mode := Ind; unk.offset := 8; + DevCPC486.Load(unk, {}, {}); + DevCPL486.GenComp(c, unk); + DevCPL486.GenJump(4, nil, TRUE); + DevCPL486.MakeReg(c, int.reg, Pointer); + DevCPL486.GenPush(c); + c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer; + DevCPL486.GenPush(c); + DevCPL486.GenPush(unk); + c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer; + DevCPL486.GenMove(c, unk); + unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer; + DevCPL486.GenCall(unk); + DevCPC486.Free(unk); + DevCPL486.GenJump(-1, end, FALSE); + DevCPL486.SetLabel(nil); + DevCPL486.MakeConst(c, 80004002H, Int32); (* E_NOINTERFACE *) + DevCPC486.Result(proc, c); + CompareIntTypes(typ, id, end, num); + IF num > 0 THEN + DevCPC486.Load(this, {}, {}); + DevCPC486.Assign(int, this); + DevCPC486.IPAddRef(this, 0, FALSE); + DevCPL486.MakeConst(c, 0, Int32); (* S_OK *) + DevCPC486.Result(proc, c); + END; + DevCPL486.SetLabel(end) + END InstallQueryInterface; + + (* -------------------- *) + + PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item); + VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN; + BEGIN + IF n # NIL THEN + ActualPar(n.link, fp.link, FALSE, ap); + niltest := FALSE; + IF fp.mode = VarPar THEN + IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN + expr(n.right, ap, {}, {}); DevCPC486.Push(ap); (* push type/length *) + expr(n.left, ap, {}, {}); DevCPC486.Push(ap); (* push adr *) + RETURN + ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN + IPFree(n, ap) + ELSE + x := n; + WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END; + niltest := x.class = Nderef; (* explicit nil test needed *) + AdrExpr(n, ap, {}, {}) + END + ELSIF (n.class = Nmop) & (n.subcl = conv) THEN + IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265) + ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form)) + & (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high}); + ELSE expr(n, ap, {}, {high}); + END + ELSE expr(n, ap, {}, {high}); + IF CountedPtr(n) THEN DevCPM.err(270) END + END; + DevCPC486.Param(fp, rec, niltest, ap, tag) + END + END ActualPar; + + PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE; + BEGIN + IF n.left.class = Nproc THEN + proc := n.left.obj; m := proc.mode; + ELSE proc := NIL; m := 0 + END; + IF (m = CProc) & (n.right # NIL) THEN + ActualPar(n.right.link, n.obj.link, FALSE, tag); + expr(n.right, tag, wreg - {AX}, {}); (* tag = first param *) + ELSE + IF proc # NIL THEN DevCPC486.PrepCall(proc) END; + ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag); + END; + IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END; + DevCPC486.Call(x, tag) + END Call; + + PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + VAR offset: INTEGER; + BEGIN + IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN + expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval; + IF n.subcl = minus THEN offset := -offset END + ELSE + expr(n, x, hint, stop + {mem}); offset := 0 + END; + DevCPC486.Mem(x, offset, typ) + END Mem; + + PROCEDURE^ CompStat (n: DevCPT.Node); + PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + + PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label); + VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct; + BEGIN + IF n.class = Nmop THEN + CASE n.subcl OF + not: condition(n.left, x, true, false); DevCPC486.Not(x) + | is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem}) + ELSE design(n.left, x, {}, {}) + END; + DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE) + | odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x) + | cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool + | val: DevCPM.err(220) + END + ELSIF n.class = Ndop THEN + CASE n.subcl OF + and: local := DevCPL486.NewLbl; condition(n.left, y, false, local); + DevCPC486.JumpF(y, false); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | or: local := DevCPL486.NewLbl; condition(n.left, y, local, true); + DevCPC486.JumpT(y, true); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | eql..geq: + f := n.left.typ.form; + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN {String8, String16, Comp} THEN + IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN (* converted must be source *) + StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE) + ELSE + StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE) + END + ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x) + ELSE + IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END; + DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk}); + IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END + | in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk}); + DevCPC486.In(x, y) + | bit: Check(n.left, ux, sx); + expr(n.right, x, {}, ux + {short}); + Mem(n.left, y, DevCPT.notyp, {}, {}); + DevCPC486.Load(x, {}, {short}); + DevCPC486.In(x, y) + | queryfn: + AdrExpr(n.right, x, {}, {CX, SI, DI}); + CompareIntTypes(n.left.typ, x, false, num); + IF num > 0 THEN + Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y); + x.offset := 1 (* true *) + ELSE x.offset := 0 (* false *) + END; + x.mode := Con; DevCPC486.MakeCond(x) + END + ELSIF n.class = Ncomp THEN + CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END + ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x) (* const, var, or call *) + END + END condition; + + PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label; + uy: SET; sy: INTEGER; r: REAL; + BEGIN + f := n.typ.form; + IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN + false := DevCPL486.NewLbl; true := DevCPL486.NewLbl; + condition(n, y, false, true); + DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem}) + ELSE + CASE n.class OF + Nconst: + IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END; + CASE f OF + Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f) + | Int64: + DevCPL486.MakeConst(x, cval.intval, f); + DevCPE.GetLongWords(cval, x.scale, x.offset) + | Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set) + | String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f) + | Comp: + ASSERT(n.typ = DevCPT.guidtyp); + IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x) + ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x) + END + END + | Nupto: (* n.typ = DevCPT.settyp *) + Check(n.right, uy, sy); + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {}); + DevCPC486.Assert(x, {}, uy); + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {}); + DevCPC486.Load(x, hint + stop, {}); + IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y + ELSE DevCPC486.IntDOp(x, y, msk, FALSE) + END + | Nmop: + CASE n.subcl OF + | bit: + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {}) + | conv: + IF f IN {String8, String16} THEN + expr(n.left, x, hint, stop); + IF f = String8 THEN x.form := VString16to8 END (* SHORT *) + ELSE + IF n.left.class = Nconst THEN (* largeint -> longreal *) + ASSERT((n.left.typ.form = Int64) & (f = Real64)); + DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form); + ELSE + expr(n.left, x, hint + stop, {high}); + END; + DevCPC486.Convert(x, f, -1, hint + stop, {}) (* ??? *) + END + | val: + expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop) (* ??? *) + | adr: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + ELSE + AdrExpr(n.left, x, hint + stop, {}); + END; + DevCPC486.GetAdr(x, hint + stop, {}) + | typfn: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + IF x.obj.typ.untagged THEN DevCPM.err(111) END + ELSE + expr(n.left, x, hint + stop, {}); + DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y + END; + DevCPC486.Load(x, hint + stop, {}) + | minus, abs, cap: + expr(n.left, x, hint + stop, {mem, stk}); + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl) + ELSE DevCPC486.IntMOp(x, n.subcl) + END + END + | Ndop: + IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN + IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN + expr(n.left, x, {}, {mem, stk}); + cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1; + WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END; + DevCPL486.AllocConst(y, cval, Real32); + DevCPC486.FloatDOp(x, y, times, FALSE) + ELSE FloatDOp(n, x) + END + ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {}) + ELSE + CASE n.subcl OF + times: + IF f = Int8 THEN + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk}); + DevCPC486.IntDOp(x, y, times, FALSE) + ELSE IntDOp(n, x, hint + stop) + END + | div, mod: + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk}); + DevCPC486.DivMod(x, y, n.subcl = mod) + | plus: + IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {}) + ELSE IntDOp(n, x, hint + stop) + END + | slash, minus, msk, min, max: + IntDOp(n, x, hint + stop) + | ash, lsh, rot: + uy := {}; IF n.right.class # Nconst THEN uy := {CX} END; + DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk}); + DevCPC486.Shift(x, y, n^.subcl) + | len: + IF n.left.typ.form IN {String8, String16} THEN + expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + DevCPC486.StrLen(x, n.left.typ, FALSE) + ELSE + design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y) + END + END + END + | Ncall: + Call(n, x) + | Ncomp: + CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END + ELSE + design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {}) (* ??? *) + END + END; + x.typ := n.typ; + DevCPC486.Assert(x, hint, stop) + END expr; + + PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN); + VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX}); + IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END; + expr(n, src, wreg - {SI}, {}); + adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con}); + IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END; + DevCPC486.Load(dadr, {}, wreg - {DI} + {con}); + DevCPC486.AddCopy(dest, src, last) + END AddCopy; + + PROCEDURE StringCopy (left, right: DevCPT.Node); + VAR x, y, ax, ay, len: DevCPL486.Item; + BEGIN + IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI}) (* keep len descriptor *) + ELSE expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI}); + DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {}); + WHILE right.class = Ndop DO + ASSERT(right.subcl = plus); + AddCopy(right.left, x, ax, len, FALSE); + right := right.right + END; + AddCopy(right, x, ax, len, TRUE); + DevCPC486.Free(len) + END StringCopy; + + PROCEDURE Checkpc; + BEGIN + DevCPE.OutSourceRef(DevCPM.errpos) + END Checkpc; + + PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + + PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label); + VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node; + BEGIN + local := DevCPL486.NewLbl; + DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left; + IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq) + & (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq) + & SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN (* reuse comparison *) + DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2) + ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is) + & SameExp(cond.left, last.left) THEN + DevCPC486.ShortTypTest(x, cond.obj.typ) (* !!! *) + ELSE condition(cond, x, else, local) + END; + hint := x.reg; + DevCPC486.JumpF(x, else); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + stat(if.right, end); + END CondStat; + + PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label); + VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER; + BEGIN (* n.class = Nifelse *) + if := n.left; last := NIL; + WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO + else := DevCPL486.NewLbl; + CondStat(if, last, hint, else, end); + IF sequential THEN DevCPC486.Jump(end) END; + DevCPL486.SetLabel(else); last := if.left; if := if.link + END; + IF n.right # NIL THEN stat(n.right, end) + ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE + ELSE CondStat(if, last, hint, end, end) + END + END IfStat; + + PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN); + VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER; + BEGIN + IF n # NIL THEN + this := SHORT(ENTIER(n.conval.realval)); + IF useTree IN n.conval.setval THEN + IF n.left # NIL THEN + IF n.right # NIL THEN + higher := DevCPL486.NewLbl; + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE); + CasePart(n.left, x, else, FALSE); + DevCPL486.SetLabel(higher); + CasePart(n.right, x, else, last) + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE); + CasePart(n.left, x, else, last); + END + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE); + IF n.right # NIL THEN CasePart(n.right, x, else, last) + ELSIF ~last THEN DevCPC486.Jump(else) + END + END + ELSE + IF useTable IN n.conval.setval THEN + m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval; + m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2; + DevCPC486.CaseTableJump(x, low, high, else); + actual := low; last := TRUE + END; + CasePart(n.left, x, else, FALSE); + WHILE actual < n.conval.intval DO + DevCPL486.GenCaseEntry(else, FALSE); INC(actual) + END; + WHILE actual < n.conval.intval2 DO + DevCPL486.GenCaseEntry(this, FALSE); INC(actual) + END; + DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual); + CasePart(n.right, x, else, last) + END; + n.conval.realval := this + END + END CasePart; + + PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label; + BEGIN + expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl; + IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN (* jump to goto optimization *) + CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x); + n.right.right.right.conval.intval2 := else; sequential := FALSE + ELSE + CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x); + DevCPL486.SetLabel(else); + IF n.right.conval.setval # {} THEN stat(n.right.right, end) + ELSE DevCPC486.Trap(caseTrap); sequential := FALSE + END + END; + case := n.right.left; + WHILE case # NIL DO (* case.class = Ncasedo *) + IF sequential THEN DevCPC486.Jump(end) END; + lab := case.left; + IF (case.right # NIL) & (case.right.class = Ngoto) THEN (* jump to goto optimization *) + case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval)); + ASSERT(lab.link = NIL); sequential := FALSE + ELSE + WHILE lab # NIL DO + this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link + END; + stat(case.right, end) + END; + case := case.link + END + END CaseStat; + + PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); + VAR len: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END; + expr(n, len, {}, {mem, short}); + IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END; + IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END; + DevCPC486.MulDim(len, nofel, fact, dimtyp); + IF n.link # NIL THEN + Dim(n.link, x, nofel, fact, dimtyp.BaseTyp); + ELSE + DevCPC486.New(x, nofel, fact) + END; + DevCPC486.SetDim(x, len, dimtyp) + END Dim; + + PROCEDURE CompStat (n: DevCPT.Node); + VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct; + BEGIN + Checkpc; + WHILE (n # NIL) & DevCPM.noerr DO + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF n.right.typ.form IN {String8, String16} THEN + StringCopy(n.left, n.right) + ELSE + IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN + IPAssign(NIL, n.right, x, y, {}); (* no Release *) + ELSE expr(n.right, y, {}, {}) + END; + expr(n.left, x, {}, {}); + DevCPC486.Assign(x, y) + END + ELSE ASSERT(n.subcl = newfn); + typ := n.left.typ.BaseTyp; + ASSERT(typ.comp = DynArr); + ASSERT(n.right.link = NIL); + expr(n.right, y, {}, wreg - {CX} + {mem, stk}); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPC486.CopyReg(sp, old, {}, {CX}); + DevCPC486.CopyReg(y, len, {}, {CX}); + IF typ.BaseTyp.form = Char16 THEN + DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE) + END; + DevCPC486.StackAlloc; + DevCPC486.Free(y); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp); + DevCPC486.Push(len); + DevCPC486.Push(old); + typ.sysflag := stackArray + END; + n := n.link + END + END CompStat; + + PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + VAR x, y, sp: DevCPL486.Item; + BEGIN + IF n.link # NIL THEN CompRelease(n.link, res) END; + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN + IF res.mode = Cond THEN + DevCPL486.GenCode(9CH); (* push flags *) + res.mode := Stk + ELSIF res.mode = Reg THEN + IF res.form < Int16 THEN DevCPC486.Push(res) + ELSE DevCPC486.Assert(res, {}, {AX, CX, DX}) + END + END; + expr(n.left, x, wreg - {DI}, {loaded}); + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + n.left.obj.used := FALSE + END + ELSE ASSERT(n.subcl = newfn); + DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp); + DevCPL486.MakeConst(y, 0, Pointer); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + END + END CompRelease; + + PROCEDURE Assign(n: DevCPT.Node; ux: SET); + VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER; + BEGIN + r := n.right; f := r.typ.form; uf := {}; + IF (r.class IN {Nmop, Ndop}) THEN + IF (r.subcl = conv) & (f # Set) & +(* + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left; + IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *) +*) + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) & + ((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left + ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN + IF r.class = Ndop THEN + IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN + expr(r.right, y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE); + RETURN + ELSIF r.subcl IN {ash, lsh, rot} THEN + expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl); + RETURN + END + ELSE + IF r.subcl IN {minus, abs, cap} THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN + END + END + ELSIF f = Bool THEN + IF (r.subcl = not) & SameExp(n.left, r.left) THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN + END + END + END; + IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux) + ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded}); (* high ??? *) + END; + DevCPC486.Assign(x, y) + END Assign; + + PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET; + BEGIN + sequential := TRUE; INC(nesting); + WHILE (n # NIL) & DevCPM.noerr DO + IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END; + DevCPM.errpos := n.conval.intval; DevCPL486.BegStat; + CASE n.class OF + | Ninittd: + (* done at load-time *) + | Nassign: + Checkpc; + Check(n.left, ux, sx); + CASE n.subcl OF + assign: + IF n.left.typ.form = Comp THEN + IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN + StringCopy(n.left, n.right) + ELSE + StringOp(n.left, n.right, x, y, TRUE); + IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END; + DevCPC486.Copy(x, y, FALSE) + END + ELSE Assign(n, ux) + END + | getfn: + Mem(n.right, y, n.left.typ, {}, ux); + expr(n.left, x, {}, {loaded}); + DevCPC486.Assign(x, y) + | putfn: + expr(n.right, y, {}, ux); + Mem(n.left, x, n.right.typ, {}, {}); + DevCPC486.Assign(x, y) + | incfn, decfn: + expr(n.right, y, {}, ux); expr(n.left, x, {}, {}); + IF n.left.typ.form = Int64 THEN + DevCPC486.LargeInc(x, y, n.subcl = decfn) + ELSE + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE) + END + | inclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE) + | exclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE) + | getrfn: + expr(n.right, y, {}, {}); + IF y.offset < 8 THEN + DevCPL486.MakeReg(y, y.offset, n.left.typ.form); (* ??? *) + expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | putrfn: + expr(n.left, x, {}, {}); + IF x.offset < 8 THEN + DevCPL486.MakeReg(x, x.offset, n.right.typ.form); (* ??? *) + expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | newfn: + y.typ := n.left.typ; + IF n.right # NIL THEN + IF y.typ.BaseTyp.comp = Record THEN + expr(n.right, nofel, {}, {AX, CX, DX, mem, stk}); + DevCPC486.New(y, nofel, 1); + ELSE (*open array*) + nofel.mode := Con; nofel.form := Int32; fact := 1; + Dim(n.right, y, nofel, fact, y.typ.BaseTyp) + END + ELSE + DevCPL486.MakeConst(nofel, 0, Int32); + DevCPC486.New(y, nofel, 1); + END; + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + | sysnewfn: + expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + | copyfn: + StringOp(n.left, n.right, x, y, TRUE); + DevCPC486.Copy(x, y, TRUE) + | movefn: + Check(n.right.link, uz, sz); + expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz); + expr(n.left, x, {}, wreg - {DI} + {short} + uz); + expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short}); + DevCPC486.Load(x, {}, wreg - {DI} + {con}); + DevCPC486.Load(y, {}, wreg - {SI} + {con}); + DevCPC486.SysMove(nofel) + END; + sequential := TRUE + | Ncall: + Checkpc; + Call(n, x); sequential := TRUE + | Nifelse: + IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END + | Ncase: + Checkpc; + CaseStat(n, next) + | Nwhile: + local := DevCPL486.NewLbl; + IF n.right # NIL THEN DevCPC486.Jump(local) END; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + stat(n.right, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE + | Nrepeat: + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE + | Nloop: + prevExit := Exit; Exit := next; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop); + IF sequential THEN DevCPC486.Jump(loop) END; + next := Exit; Exit := prevExit; sequential := FALSE + | Nexit: + Checkpc; + DevCPC486.Jump(Exit); sequential := FALSE + | Nreturn: + IF n.left # NIL THEN + Checkpc; + IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer) + & (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {}) + ELSE expr(n.left, x, wreg - {AX}, {}) + END; + DevCPC486.Result(n.obj, x) + END; + IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END; + sequential := FALSE + | Nwith: + IfStat(n, n.subcl = 0, next) + | Ntrap: + Checkpc; + DevCPC486.Trap(n.right.conval.intval); sequential := TRUE + | Ncomp: + CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x) + | Ndrop: + Checkpc; + expr(n.left, x, {}, {}); DevCPC486.Free(x) + | Ngoto: + IF n.left # NIL THEN + Checkpc; + condition(n.left, x, next, n.right.conval.intval2); + DevCPC486.JumpT(x, n.right.conval.intval2) + ELSE + DevCPC486.Jump(n.right.conval.intval2); + sequential := FALSE + END + | Njsr: + DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE) (* call n.right *) + | Nret: + DevCPL486.GenReturn(0); sequential := FALSE (* ret 0 *) + | Nlabel: + DevCPL486.SetLabel(n.conval.intval2) + END; + DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link; + IF n = NIL THEN end := next + ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next) + END + END; + DEC(nesting) + END stat; + + PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN); + BEGIN + WHILE n # NIL DO + IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END; + CASE n.class OF + | Ncase: + CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu) + | Ncasedo: + CheckFpu(n.right, useFpu) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + CheckFpu(n.left, useFpu) + | Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END CheckFpu; + + PROCEDURE procs(n: DevCPT.Node); + VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label; + ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN; + BEGIN + INC(DevCPL486.level); nesting := 0; + WHILE (n # NIL) & DevCPM.noerr DO + DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj; + IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END; + procs(n.left); + DevCPM.errpos := n.conval.intval; + useFpu := FALSE; CheckFpu(n.right, useFpu); + DevCPC486.Enter(proc, n.right = NIL, useFpu); + InitializeIPVars(proc); + end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end); + DevCPM.errpos := n.conval.intval2; Checkpc; + IF sequential OR (end # DevCPL486.NewLbl) THEN + DevCPL486.SetLabel(end); + IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END + END; + DevCPL486.SetLabel(Return); + ReleaseIPVars(proc); + DevCPC486.Exit(proc, n.right = NIL); + IF proc.mode = TProc THEN + name := proc.link.typ.strobj.name^$; i := 0; + WHILE name[i] # 0X DO INC(i) END; + name[i] := "."; INC(i); j := 0; ch := proc.name[0]; + WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ; + name[i] := 0X; + ELSE name := proc.name^$ + END; + DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right); + n := n.link + END; + DEC(DevCPL486.level) + END procs; + + PROCEDURE Module*(prog: DevCPT.Node); + VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node; + aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN; + BEGIN + DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop}); + DevCPM.NewObj(DevCPT.SelfName); + IF DevCPM.noerr THEN + DevCPE.OutHeader; n := prog.right; + WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END; + useFpu := FALSE; CheckFpu(n, useFpu); + DevCPC486.Enter(NIL, n = NIL, useFpu); + end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end); + DevCPM.errpos := prog.conval.intval2; Checkpc; + DevCPC486.Exit(NIL, n = NIL); + IF prog.link # NIL THEN (* close section *) + DevCPL486.SetLabel(DevCPE.closeLbl); + useFpu := FALSE; CheckFpu(prog.link, useFpu); + DevCPC486.Enter(NIL, FALSE, useFpu); + end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end); + DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc; + DevCPC486.Exit(NIL, FALSE) + END; + name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right); + DevCPM.errpos := prog.conval.intval; + WHILE query # NIL DO + typ := query.typ; query.typ := DevCPT.int32typ; + query.conval.intval := 20; (* parameters *) + query.conval.intval2 := -8; (* saved registers *) + DevCPC486.Enter(query, FALSE, FALSE); + InstallQueryInterface(typ, query); + DevCPC486.Exit(query, FALSE); + name := "QueryInterface"; DevCPE.OutRefName(name); + query := query.nlink + END; + procs(prog.left); + DevCPC486.InstallStackAlloc; + addRef := NIL; release := NIL; release2 := NIL; + DevCPC486.intHandler := NIL; + IF DevCPM.noerr THEN DevCPE.OutCode END; + IF ~DevCPM.noerr THEN DevCPM.DeleteObj END + END + END Module; + +END DevCPV486. diff --git a/Trurl-based/Dev/Mod/Commanders.txt b/Trurl-based/Dev/Mod/Commanders.txt new file mode 100644 index 0000000..4d102e7 --- /dev/null +++ b/Trurl-based/Dev/Mod/Commanders.txt @@ -0,0 +1,361 @@ +MODULE DevCommanders; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Commanders.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Fonts, Ports, Stores, Models, Views, Controllers, Properties, Dialog, Controls, + TextModels, TextSetters, TextMappers, Services, StdLog; + + CONST + (* additional Scan types *) + ident = 19; qualident = 20; execMark = 21; + + point = Ports.point; + + minVersion = 0; maxVersion = 0; maxStdVersion = 0; + + + TYPE + View* = POINTER TO ABSTRACT RECORD (Views.View) + END; + EndView* = POINTER TO ABSTRACT RECORD (Views.View) + END; + + Par* = POINTER TO RECORD + text*: TextModels.Model; + beg*, end*: INTEGER + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + + StdView = POINTER TO RECORD (View) END; + StdEndView = POINTER TO RECORD (EndView) END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + Scanner = RECORD + s: TextMappers.Scanner; + ident: ARRAY LEN(Kernel.Name) OF CHAR; + qualident: ARRAY LEN(Kernel.Name) * 2 - 1 OF CHAR + END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + + VAR + par*: Par; + dir-, stdDir-: Directory; + + cleaner: TrapCleaner; + cleanerInstalled: BOOLEAN; + + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + par := NIL; + cleanerInstalled := FALSE; + END Cleanup; + + (** View **) + + PROCEDURE (v: View) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + v.Externalize^(wr); + wr.WriteVersion(maxVersion); + wr.WriteXInt(execMark) + END Externalize; + + PROCEDURE (v: View) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion, type: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadXInt(type) + END Internalize; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (): View, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewEnd* (): EndView, NEW, ABSTRACT; + + + (* auxilliary procedures *) + + PROCEDURE IsIdent (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; ch: CHAR; + BEGIN + ch := s[0]; i := 1; + IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN + REPEAT + ch := s[i]; INC(i) + UNTIL ~( ("0" <= ch) & (ch <= "9") OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") ); + RETURN (ch = 0X) & (i <= LEN(Kernel.Name)) + ELSE + RETURN FALSE + END + END IsIdent; + + PROCEDURE Scan (VAR s: Scanner); + VAR done: BOOLEAN; + BEGIN + s.s.Scan; + IF (s.s.type = TextMappers.view) THEN + IF Properties.ThisType(s.s.view, "DevCommanders.View") # NIL THEN s.s.type := execMark END + ELSIF (s.s.type = TextMappers.string) & TextMappers.IsQualIdent(s.s.string) THEN + s.s.type := qualident; s.qualident := s.s.string$ + ELSIF (s.s.type = TextMappers.string) & IsIdent(s.s.string) THEN + s.ident := s.s.string$; + TextMappers.ScanQualIdent(s.s, s.qualident, done); + IF done THEN s.s.type := qualident ELSE s.s.type := ident END + END + END Scan; + + PROCEDURE GetParExtend (r: TextModels.Reader; VAR end: INTEGER); + VAR v, v1: Views.View; + BEGIN + REPEAT r.ReadView(v); + IF v # NIL THEN + v1 := v; + v := Properties.ThisType(v1, "DevCommanders.View") ; + IF v = NIL THEN v := Properties.ThisType(v1, "DevCommanders.EndView") END + END + UNTIL r.eot OR (v # NIL); + end := r.Pos(); IF ~r.eot THEN DEC(end) END + END GetParExtend; + + PROCEDURE Unload (cmd: Dialog.String); + VAR modname: Kernel.Name; str: Dialog.String; i: INTEGER; ch: CHAR; mod: Kernel.Module; + BEGIN + i := 0; ch := cmd[0]; + WHILE (ch # 0X) & (ch # ".") DO modname[i] := SHORT(ch); INC(i); ch := cmd[i] END; + modname[i] := 0X; + mod := Kernel.ThisLoadedMod(modname); + IF mod # NIL THEN + Kernel.UnloadMod(mod); + IF mod.refcnt < 0 THEN + str := modname$; + Dialog.MapParamString("#Dev:Unloaded", str, "", "", str); + StdLog.String(str); StdLog.Ln; + Controls.Relink + ELSE + str := modname$; + Dialog.ShowParamMsg("#Dev:UnloadingFailed", str, "", "") + END + END + END Unload; + + PROCEDURE Execute (t: TextModels.Model; pos: INTEGER; VAR end: INTEGER; unload: BOOLEAN); + VAR s: Scanner; beg, res: INTEGER; cmd: Dialog.String; + BEGIN + end := t.Length(); + s.s.ConnectTo(t); s.s.SetPos(pos); s.s.SetOpts({TextMappers.returnViews}); + Scan(s); ASSERT(s.s.type = execMark, 100); + Scan(s); + IF s.s.type IN {qualident, TextMappers.string} THEN + beg := s.s.Pos() - 1; GetParExtend(s.s.rider, end); + ASSERT(~cleanerInstalled, 101); + Kernel.PushTrapCleaner(cleaner); cleanerInstalled := TRUE; + NEW(par); par.text := t; par.beg := beg; par.end := end; + IF s.s.type = qualident THEN cmd := s.qualident$ ELSE cmd := s.s.string$ END; + IF unload (* & (s.s.type = qualident)*) THEN Unload(cmd) END; + Dialog.Call(cmd, " ", res); + par := NIL; + Kernel.PopTrapCleaner(cleaner); cleanerInstalled := FALSE; + END + END Execute; + + PROCEDURE Track (v: View; f: Views.Frame; x, y: INTEGER; buttons: SET); + VAR c: Models.Context; w, h, end: 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); + WITH c:TextModels.Context DO + Execute(c.ThisModel(), c.Pos(), end,Controllers.modify IN buttons) + ELSE Dialog.Beep + END + END + END Track; + + (* StdView *) + + PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer); + BEGIN + v.Externalize^(wr); + wr.WriteVersion(maxStdVersion) + END Externalize; + + PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdVersion, thisVersion) + END Internalize; + + PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + CONST u = point; + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + size, d, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR; + BEGIN + ASSERT(v.context # NIL, 20); + c := v.context; + WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color + ELSE font := Fonts.dir.Default(); color := Ports.defaultColor + END; + font.GetBounds(asc, dsc, fw); + size := asc + dsc; d := size DIV 2; + f.DrawOval(u, 0, u + size, size, Ports.fill, color); + s := "!"; + w := font.StringWidth(s); + f.DrawString(u + d - w DIV 2, size - dsc, Ports.background, s, font) + END Restore; + + 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; + + PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + WITH msg: Properties.Preference DO + WITH msg: Properties.SizePref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, fw); + msg.h := asc + dsc; msg.w := msg.h + 2 * point + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + msg.hotFocus := TRUE + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, fw) + | msg: Properties.TypePref DO + IF Services.Is(v, msg.type) THEN msg.view := v END + ELSE + END + ELSE + END + END HandlePropMsg; + + + (* StdEndView *) + + PROCEDURE (v: StdEndView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + CONST u = point; + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + size, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR; + points: ARRAY 3 OF Ports.Point; + BEGIN + ASSERT(v.context # NIL, 20); + c := v.context; + WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color + ELSE font := Fonts.dir.Default(); color := Ports.defaultColor + END; + font.GetBounds(asc, dsc, fw); + size := asc + dsc; + points[0].x := 0; points[0].y := size; + points[1].x := u + (size DIV 2); points[1].y := size DIV 2; + points[2].x := u + (size DIV 2); points[2].y := size; + f.DrawPath(points, 3, Ports.fill, color, Ports.closedPoly) + END Restore; + + PROCEDURE (v: StdEndView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + WITH msg: Properties.Preference DO + WITH msg: Properties.SizePref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, fw); + msg.h := asc + dsc; msg.w := (msg.h + 2 * point) DIV 2 + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + msg.hotFocus := TRUE + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, fw) + | msg: Properties.TypePref DO + IF Services.Is(v, msg.type) THEN msg.view := v END + ELSE + END + ELSE + END + END HandlePropMsg; + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (): View; + VAR v: StdView; + BEGIN + NEW(v); RETURN v + END New; + + PROCEDURE (d: StdDirectory) NewEnd (): EndView; + VAR v: StdEndView; + BEGIN + NEW(v); RETURN v + END NewEnd; + + PROCEDURE Deposit*; + BEGIN + Views.Deposit(dir.New()) + END Deposit; + + PROCEDURE DepositEnd*; + BEGIN + Views.Deposit(dir.NewEnd()) + END DepositEnd; + + PROCEDURE SetDir* (d: Directory); + BEGIN + dir := d + END SetDir; + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + NEW(d); dir := d; stdDir := d; + NEW(cleaner); cleanerInstalled := FALSE; + END Init; + +BEGIN + Init +END DevCommanders. diff --git a/Trurl-based/Dev/Mod/Compiler.txt b/Trurl-based/Dev/Mod/Compiler.txt new file mode 100644 index 0000000..6aa0761 --- /dev/null +++ b/Trurl-based/Dev/Mod/Compiler.txt @@ -0,0 +1,348 @@ +MODULE DevCompiler; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Compiler.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, + Files, Views, Dialog, Controls, + TextModels, TextMappers, TextViews, TextControllers, + StdLog, StdDialog, + DevMarkers, DevCommanders, DevSelectors, + DevCPM, DevCPT, DevCPB, DevCPP, DevCPE, DevCPV := DevCPV486; + + CONST + (* compiler options: *) + checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; srcpos = 6; reallib = 7; signatures = 8; + hint = 29; oberon = 30; errorTrap = 31; + defopt = {checks, assert, obj, ref, allref, srcpos, signatures}; + + (* additional scanner types *) + import = 100; module = 101; semicolon = 102; becomes = 103; comEnd = 104; + + VAR + sourceR: TextModels.Reader; + s: TextMappers.Scanner; + str: Dialog.String; + found: BOOLEAN; (* DevComDebug was found -> DTC *) + + PROCEDURE Module (source: TextModels.Reader; opt: SET; log: TextModels.Model; VAR error: BOOLEAN); + VAR ext, new: BOOLEAN; p: DevCPT.Node; + BEGIN + DevCPM.Init(source, log); + IF found THEN INCL(DevCPM.options, DevCPM.comAware) END; + IF errorTrap IN opt THEN INCL(DevCPM.options, DevCPM.trap) END; + IF oberon IN opt THEN INCL(DevCPM.options, DevCPM.oberon) END; + DevCPT.Init(opt); + DevCPB.typSize := DevCPV.TypeSize; + DevCPT.processor := DevCPV.processor; + DevCPP.Module(p); + IF DevCPM.noerr THEN + IF DevCPT.libName # "" THEN EXCL(opt, obj) END; +(* + IF errorTrap IN opt THEN DevCPDump.DumpTree(p) END; +*) + DevCPV.Init(opt); DevCPV.Allocate; DevCPT.Export(ext, new); + IF DevCPM.noerr & (obj IN opt) THEN + DevCPV.Module(p) + END; + DevCPV.Close + END; + IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym + ELSE DevCPM.DeleteNewSym + END; + DevCPT.Close; + error := ~DevCPM.noerr; + DevCPM.Close; + p := NIL; + Kernel.FastCollect; + IF error THEN + DevCPM.InsertMarks(source.Base()); + DevCPM.LogWLn; DevCPM.LogWStr(" "); + IF DevCPM.errors = 1 THEN + Dialog.MapString("#Dev:OneErrorDetected", str) + ELSE + DevCPM.LogWNum(DevCPM.errors, 0); Dialog.MapString("#Dev:ErrorsDetected", str) + END; + StdLog.String(str) + ELSE + IF hint IN opt THEN DevCPM.InsertMarks(source.Base()) END; + DevCPM.LogWStr(" "); DevCPM.LogWNum(DevCPE.pc, 8); + DevCPM.LogWStr(" "); DevCPM.LogWNum(DevCPE.dsize, 8) + END; + DevCPM.LogWLn + END Module; + + PROCEDURE Scan (VAR s: TextMappers.Scanner); + BEGIN + s.Scan; + IF s.type = TextMappers.string THEN + IF s.string = "MODULE" THEN s.type := module END + ELSIF s.type = TextMappers.char THEN + IF s.char = "(" THEN + IF s.rider.char = "*" THEN + s.rider.Read; + REPEAT Scan(s) UNTIL (s.type = TextMappers.eot) OR (s.type = comEnd); + Scan(s) + END + ELSIF s.char = "*" THEN + IF s.rider.char = ")" THEN s.rider.Read; s.type := comEnd END + END + END + END Scan; + + PROCEDURE Do (source, log: TextModels.Model; beg: INTEGER; opt: SET; VAR error: BOOLEAN); + VAR s: TextMappers.Scanner; + BEGIN + Dialog.MapString("#Dev:Compiling", str); + StdLog.String(str); StdLog.Char(" "); + s.ConnectTo(source); s.SetPos(beg); + Scan(s); + WHILE (s.type # TextMappers.eot) & (s.type # module) DO Scan(s) END; + IF s.type = module THEN + Scan(s); + IF s.type = TextMappers.string THEN + StdLog.Char('"'); StdLog.String(s.string); StdLog.Char('"') + END + END; + sourceR := source.NewReader(NIL); sourceR.SetPos(beg); + Module(sourceR, opt, log, error) + END Do; + + + PROCEDURE Open; + BEGIN + Dialog.ShowStatus("#Dev:Compiling"); + StdLog.buf.Delete(0, StdLog.buf.Length()) + END Open; + + PROCEDURE Close; + BEGIN + StdLog.text.Append(StdLog.buf); + IF DevCPM.noerr THEN Dialog.ShowStatus("#Dev:Ok") + END; + sourceR := NIL; + Kernel.Cleanup + END Close; + + PROCEDURE Compile*; + VAR t: TextModels.Model; error: BOOLEAN; + BEGIN + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END Compile; + + PROCEDURE CompileOpt* (opt: ARRAY OF CHAR); + VAR t: TextModels.Model; error: BOOLEAN; i: INTEGER; opts: SET; + BEGIN + i := 0; opts := defopt; + WHILE opt[i] # 0X DO + IF opt[i] = "-" THEN + IF srcpos IN opts THEN EXCL(opts, srcpos) + ELSIF allref IN opts THEN EXCL(opts, allref) + ELSIF ref IN opts THEN EXCL(opts, ref) + ELSE EXCL(opts, obj) + END + ELSIF opt[i] = "!" THEN + IF assert IN opts THEN EXCL(opts, assert) + ELSE EXCL(opts, checks) + END + ELSIF opt[i] = "+" THEN INCL(opts, allchecks) + ELSIF opt[i] = "?" THEN INCL(opts, hint) + ELSIF opt[i] = "@" THEN INCL(opts, errorTrap) + ELSIF opt[i] = "$" THEN INCL(opts, oberon) + END; + INC(i) + END; + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, opts, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileOpt; + + PROCEDURE CompileText* (text: TextModels.Model; beg: INTEGER; OUT error: BOOLEAN); + BEGIN + ASSERT(text # NIL, 20); ASSERT((beg >= 0) & (beg < text.Length()), 21); + Open; + Do(text, StdLog.text, beg, defopt, error); + IF error THEN DevMarkers.ShowFirstError(text, TextViews.focusOnly) END; + Close + END CompileText; + + PROCEDURE CompileAndUnload*; + VAR t: TextModels.Model; error: BOOLEAN; mod: Kernel.Module; n: ARRAY 256 OF CHAR; + BEGIN + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) + ELSE + mod := Kernel.ThisLoadedMod(DevCPT.SelfName); + IF mod # NIL THEN + Kernel.UnloadMod(mod); + n := DevCPT.SelfName$; + IF mod.refcnt < 0 THEN + Dialog.MapParamString("#Dev:Unloaded", n, "", "", str); + StdLog.String(str); StdLog.Ln; + Controls.Relink + ELSE + Dialog.MapParamString("#Dev:UnloadingFailed", n, "", "", str); + StdLog.String(str); StdLog.Ln + END + END + END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileAndUnload; + + PROCEDURE CompileSelection*; + VAR c: TextControllers.Controller; t: TextModels.Model; beg, end: INTEGER; error: BOOLEAN; + BEGIN + Open; + c := TextControllers.Focus(); + IF c # NIL THEN + t := c.text; + IF c.HasSelection() THEN + c.GetSelection(beg, end); Do(t, StdLog.text, beg, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoSelectionFound") + END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileSelection; + + PROCEDURE CompileList (beg, end: INTEGER; c: TextControllers.Controller); + VAR v: Views.View; i: INTEGER; error, one: BOOLEAN; name: Files.Name; loc: Files.Locator; + t: TextModels.Model; opts: SET; title, entry: ARRAY 64 OF CHAR; + BEGIN + s.SetPos(beg); s.Scan; one := FALSE; + WHILE (s.start < end) & (s.type = TextMappers.string) & (s.len < LEN(name)) DO + s.Scan; one := TRUE; + WHILE (s.start < end) & (s.type = TextMappers.char) & + ((s.char = "-") OR (s.char = "+") OR + (s.char = "!") OR (s.char = "*") OR (s.char = "?") OR (s.char = "^") OR (s.char = "(")) + DO + IF s.char = "(" THEN + WHILE (s.start < end) & ((s.type # TextMappers.char) OR (s.char # ")")) DO s.Scan END + END; + s.Scan + END + END; + IF one & (s.start >= end) THEN + s.SetPos(beg); s.Scan; error := FALSE; + WHILE (s.start < end) & (s.type = TextMappers.string) & ~error DO + i := 0; WHILE i < LEN(name) DO name[i] := 0X; INC(i) END; + StdDialog.GetSubLoc(s.string, "Mod", loc, name); + t := NIL; + IF loc # NIL THEN + v := Views.OldView(loc, name); + IF v # NIL THEN + WITH v: TextViews.View DO t := v.ThisModel() + ELSE Dialog.ShowParamMsg("#Dev:NoTextFileFound", name, "", ""); error := TRUE + END + ELSE Dialog.ShowParamMsg("#Dev:CannotOpenFile", name, "", ""); error := TRUE + END + ELSE Dialog.ShowParamMsg("#System:FileNotFound", name, "", ""); error := TRUE + END; + s.Scan; opts := defopt; + WHILE (s.start < end) & (s.type = TextMappers.char) DO + IF s.char = "-" THEN + IF srcpos IN opts THEN EXCL(opts, srcpos) + ELSIF allref IN opts THEN EXCL(opts, allref) + ELSIF ref IN opts THEN EXCL(opts, ref) + ELSE EXCL(opts, obj) + END + ELSIF s.char = "!" THEN + IF assert IN opts THEN EXCL(opts, assert) + ELSE EXCL(opts, checks) + END + ELSIF s.char = "+" THEN INCL(opts, allchecks) + ELSIF s.char = "?" THEN INCL(opts, hint) + ELSIF s.char = "@" THEN INCL(opts, errorTrap) + ELSIF s.char = "$" THEN INCL(opts, oberon) + ELSIF s.char = "(" THEN + s.Scan; + WHILE (s.start < end) & (s.type = TextMappers.string) DO + title := s.string$; s.Scan; + IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ":") THEN + s.Scan; + IF (s.start < end) & (s.type = TextMappers.string) THEN + entry := s.string$; s.Scan; + IF t # NIL THEN DevSelectors.ChangeTo(t, title, entry) END + END + END; + IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ",") THEN s.Scan END + END + END; + s.Scan + END; + IF t # NIL THEN + Do(t, StdLog.text, 0, opts, error) + END + END + ELSE Dialog.ShowMsg("#Dev:NotOnlyFileNames") + END; + s.ConnectTo(NIL); + IF error & (c # NIL) & c.HasSelection() & (s.start < end) THEN + c.SetSelection(s.start, end) + END; + IF error & (v # NIL) THEN + Views.Open(v, loc, name, NIL); + DevMarkers.ShowFirstError(t, TextViews.any) + END + END CompileList; + + PROCEDURE CompileModuleList*; + VAR c: TextControllers.Controller; beg, end: INTEGER; + BEGIN + Open; + c := TextControllers.Focus(); + IF c # NIL THEN + s.ConnectTo(c.text); + IF c.HasSelection() THEN c.GetSelection(beg, end) + ELSE beg := 0; end := c.text.Length() + END; + CompileList(beg, end, c) + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileModuleList; + + PROCEDURE CompileThis*; + VAR p: DevCommanders.Par; beg, end: INTEGER; + BEGIN + Open; + p := DevCommanders.par; + IF p # NIL THEN + DevCommanders.par := NIL; + s.ConnectTo(p.text); beg := p.beg; end := p.end; + CompileList(beg, end, NIL) + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileThis; + + PROCEDURE Init; + VAR loc: Files.Locator; f: Files.File; + BEGIN + loc := Files.dir.This("Dev"); loc := loc.This("Code"); + f := Files.dir.Old(loc, "ComDebug.ocf", TRUE); + found := f # NIL; + IF f # NIL THEN f.Close END + END Init; + +BEGIN + Init +END DevCompiler. diff --git a/Trurl-based/Dev/Mod/ElfLinker16.odc b/Trurl-based/Dev/Mod/ElfLinker16.odc new file mode 100644 index 0000000..96b736e Binary files /dev/null and b/Trurl-based/Dev/Mod/ElfLinker16.odc differ diff --git a/Trurl-based/Dev/Mod/Linker.odc b/Trurl-based/Dev/Mod/Linker.odc new file mode 100644 index 0000000..7b64259 Binary files /dev/null and b/Trurl-based/Dev/Mod/Linker.odc differ diff --git a/Trurl-based/Dev/Mod/Markers.txt b/Trurl-based/Dev/Mod/Markers.txt new file mode 100644 index 0000000..b402b5b --- /dev/null +++ b/Trurl-based/Dev/Mod/Markers.txt @@ -0,0 +1,442 @@ +MODULE DevMarkers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Markers.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Files, Stores, Fonts, Ports, Models, Views, Controllers, Properties, Dialog, + TextModels, TextSetters, TextViews, TextControllers, TextMappers; + + CONST + (** View.mode **) + undefined* = 0; mark* = 1; message* = 2; + firstMode = 1; lastMode = 2; + + (** View.err **) + noCode* = 9999; + + errFile = "Errors"; point = Ports.point; + + TYPE + View* = POINTER TO ABSTRACT RECORD (Views.View) + mode-: INTEGER; + err-: INTEGER; + msg-: POINTER TO ARRAY OF CHAR; + era: INTEGER + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + + StdView = POINTER TO RECORD (View) END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + SetModeOp = POINTER TO RECORD (Stores.Operation) + view: View; + mode: INTEGER + END; + + + VAR + dir-, stdDir-: Directory; + + globR: TextModels.Reader; globW: TextModels.Writer; (* recycling done in Load, Insert *) + + thisEra: INTEGER; + + + (** View **) + + PROCEDURE (v: View) CopyFromSimpleView- (source: Views.View), EXTENSIBLE; + BEGIN + (* v.CopyFrom^(source); *) + WITH source: View DO + v.err := source.err; v.mode := source.mode; + IF source.msg # NIL THEN + NEW(v.msg, LEN(source.msg^)); v.msg^ := source.msg^$ + END + END + END CopyFromSimpleView; + +(* + PROCEDURE (v: View) InitContext* (context: Models.Context), EXTENSIBLE; + BEGIN + ASSERT(v.mode # undefined, 20); + v.InitContext^(context) + END InitContext; +*) + + PROCEDURE (v: View) InitErr* (err: INTEGER), NEW, EXTENSIBLE; + BEGIN + ASSERT(v.msg = NIL, 20); + IF v.err # err THEN v.err := err; v.mode := mark END; + IF v.mode = undefined THEN v.mode := mark END + END InitErr; + + PROCEDURE (v: View) InitMsg* (msg: ARRAY OF CHAR), NEW, EXTENSIBLE; + VAR i: INTEGER; str: ARRAY 1024 OF CHAR; + BEGIN + ASSERT(v.msg = NIL, 20); + Dialog.MapString(msg, str); + i := 0; WHILE str[i] # 0X DO INC(i) END; + NEW(v.msg, i + 1); v.msg^ := str$; + v.mode := mark + END InitMsg; + + PROCEDURE (v: View) SetMode* (mode: INTEGER), NEW, EXTENSIBLE; + VAR op: SetModeOp; + BEGIN + ASSERT((firstMode <= mode) & (mode <= lastMode), 20); + IF v.mode # mode THEN + NEW(op); op.view := v; op.mode := mode; + Views.Do(v, "#System:ViewSetting", op) + END + END SetMode; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (type: INTEGER): View, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewMsg* (msg: ARRAY OF CHAR): View, NEW, ABSTRACT; + + + (* SetModeOp *) + + PROCEDURE (op: SetModeOp) Do; + VAR v: View; mode: INTEGER; + BEGIN + v := op.view; + mode := v.mode; v.mode := op.mode; op.mode := mode; + Views.Update(v, Views.keepFrames); + IF v.context # NIL THEN v.context.SetSize(Views.undefined, Views.undefined) END + END Do; + + PROCEDURE ToggleMode (v: View); + VAR mode: INTEGER; + BEGIN + IF ABS(v.err) # noCode THEN + IF v.mode < lastMode THEN mode := v.mode + 1 ELSE mode := firstMode END + ELSE + IF v.mode < message THEN mode := v.mode + 1 ELSE mode := firstMode END + END; + v.SetMode(mode) + END ToggleMode; + + + (* primitives for StdView *) + + PROCEDURE NumToStr (x: INTEGER; VAR s: ARRAY OF CHAR; VAR i: INTEGER); + VAR j: INTEGER; m: ARRAY 32 OF CHAR; + BEGIN + ASSERT(x >= 0, 20); + j := 0; REPEAT m[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0; + i := 0; REPEAT DEC(j); s[i] := m[j]; INC(i) UNTIL j = 0; + s[i] := 0X + END NumToStr; + + PROCEDURE Load (v: StdView); + VAR view: Views.View; t: TextModels.Model; s: TextMappers.Scanner; + err: INTEGER; i: INTEGER; ch: CHAR; loc: Files.Locator; + msg: ARRAY 1024 OF CHAR; + BEGIN + err := ABS(v.err); NumToStr(err, msg, i); + loc := Files.dir.This("Dev"); IF loc = NIL THEN RETURN END; + loc := loc.This("Rsrc"); IF loc = NIL THEN RETURN END; + view := Views.OldView(loc, errFile); + IF (view # NIL) & (view IS TextViews.View) THEN + t := view(TextViews.View).ThisModel(); + IF t # NIL THEN + s.ConnectTo(t); + REPEAT + s.Scan + UNTIL ((s.type = TextMappers.int) & (s.int = err)) OR (s.type = TextMappers.eot); + IF s.type = TextMappers.int THEN + s.Skip(ch); i := 0; + WHILE (ch >= " ") & (i < LEN(msg) - 1) DO + msg[i] := ch; INC(i); s.rider.ReadChar(ch) + END; + msg[i] := 0X + END + END + END; + NEW(v.msg, i + 1); v.msg^ := msg$ + END Load; + + PROCEDURE DrawMsg (v: StdView; f: Views.Frame; font: Fonts.Font; color: Ports.Color); + VAR w, h, asc, dsc: INTEGER; + BEGIN + CASE v.mode OF + mark: + v.context.GetSize(w, h); + f.DrawLine(point, 0, w - 2 * point, h, 0, color); + f.DrawLine(w - 2 * point, 0, point, h, 0, color) + | message: + font.GetBounds(asc, dsc, w); + f.DrawString(2 * point, asc, color, v.msg^, font) + END + END DrawMsg; + + PROCEDURE ShowMsg (v: StdView); + BEGIN + IF v.msg = NIL THEN Load(v) END; + Dialog.ShowStatus(v.msg^) + END ShowMsg; + + PROCEDURE Track (v: StdView; f: Views.Frame; x, y: INTEGER; buttons: SET); + VAR c: Models.Context; t: TextModels.Model; u, w, h: INTEGER; isDown, in, in0: BOOLEAN; m: SET; + BEGIN + v.context.GetSize(w, h); u := f.dot; in0 := FALSE; + in := (0 <= x) & (x < w) & (0 <= y) & (y < h); + REPEAT + IF in # in0 THEN + f.MarkRect(u, 0, w - u, 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(u, 0, w - u, h, Ports.fill, Ports.invert, Ports.hide); + IF Dialog.showsStatus & ~(Controllers.modify IN buttons) & ~(Controllers.doubleClick IN buttons) THEN + ShowMsg(v) + ELSE + ToggleMode(v) + END; + c := v.context; + WITH c: TextModels.Context DO + t := c.ThisModel(); + TextControllers.SetCaret(t, c.Pos() + 1) + ELSE + END + END + END Track; + + PROCEDURE SizePref (v: StdView; VAR p: 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 := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, w); + p.h := asc + dsc; + CASE v.mode OF + mark: + p.w := p.h + 2 * point + | message: + IF v.msg = NIL THEN Load(v) END; + p.w := font.StringWidth(v.msg^) + 4 * point + END + END SizePref; + + + (* StdView *) + + PROCEDURE (v: StdView) ExternalizeAs (VAR s1: Stores.Store); + BEGIN + s1 := NIL + END ExternalizeAs; + + PROCEDURE (v: StdView) SetMode(mode: INTEGER); + BEGIN v.SetMode^(mode); ShowMsg(v) + END SetMode; + + PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + w, h: INTEGER; + BEGIN + c := v.context; c.GetSize(w, h); + WITH c: TextModels.Context DO a := c.Attr(); font := a.font ELSE font := Fonts.dir.Default() END; + IF TRUE (*f.colors >= 4*) THEN color := Ports.grey50 ELSE color := Ports.defaultColor END; + IF v.err >= 0 THEN + f.DrawRect(point, 0, w - point, h, Ports.fill, color); + DrawMsg(v, f, font, Ports.background) + ELSE + f.DrawRect(point, 0, w - point, h, 0, color); + DrawMsg(v, f, font, Ports.defaultColor) + END + END Restore; + + PROCEDURE (v: StdView) GetBackground (VAR color: Ports.Color); + BEGIN + color := Ports.background + END GetBackground; + + 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) + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; 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: Properties.StorePref DO + msg.view := NIL +*) + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE + font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, w) + ELSE + END + ELSE + END + END HandlePropMsg; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (err: INTEGER): View; + VAR v: StdView; + BEGIN + NEW(v); v.InitErr(err); RETURN v + END New; + + PROCEDURE (d: StdDirectory) NewMsg (msg: ARRAY OF CHAR): View; + VAR v: StdView; + BEGIN + NEW(v); v.InitErr(noCode); v.InitMsg(msg); RETURN v + END NewMsg; + + + (** Cleaner **) + + PROCEDURE Cleanup; + BEGIN + globR := NIL; globW := NIL + END Cleanup; + + + (** miscellaneous **) + + PROCEDURE Insert* (text: TextModels.Model; pos: INTEGER; v: View); + VAR w: TextModels.Writer; r: TextModels.Reader; + BEGIN + ASSERT(v.era = 0, 20); + Models.BeginModification(Models.clean, text); + v.era := thisEra; + IF pos > text.Length() THEN pos := text.Length() END; + globW := text.NewWriter(globW); w := globW; w.SetPos(pos); + IF pos > 0 THEN DEC(pos) END; + globR := text.NewReader(globR); r := globR; r.SetPos(pos); r.Read; + IF r.attr # NIL THEN w.SetAttr(r.attr) END; + w.WriteView(v, Views.undefined, Views.undefined); + Models.EndModification(Models.clean, text); + END Insert; + + PROCEDURE Unmark* (text: TextModels.Model); + VAR r: TextModels.Reader; v: Views.View; pos: INTEGER; + script: Stores.Operation; + BEGIN + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, "#Dev:DeleteMarkers", script); + r := text.NewReader(NIL); r.ReadView(v); + WHILE ~r.eot DO + IF r.view IS View THEN + pos := r.Pos() - 1; text.Delete(pos, pos + 1); r.SetPos(pos) + END; + r.ReadView(v) + END; + INC(thisEra); + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END Unmark; + + PROCEDURE ShowFirstError* (text: TextModels.Model; focusOnly: BOOLEAN); + VAR v1: Views.View; pos: INTEGER; + BEGIN + globR := text.NewReader(globR); globR.SetPos(0); + REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View); + IF ~globR.eot THEN + pos := globR.Pos(); + TextViews.ShowRange(text, pos, pos, focusOnly); + TextControllers.SetCaret(text, pos); + v1(View).SetMode(v1(View).mode) + END + END ShowFirstError; + + + (** commands **) + + PROCEDURE UnmarkErrors*; + VAR t: TextModels.Model; + BEGIN + t := TextViews.FocusText(); + IF t # NIL THEN Unmark(t) END + END UnmarkErrors; + + PROCEDURE NextError*; + VAR c: TextControllers.Controller; t: TextModels.Model; v1: Views.View; + beg, pos: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + t := c.text; + IF c.HasCaret() THEN pos := c.CaretPos() + ELSIF c.HasSelection() THEN c.GetSelection(beg, pos) + ELSE pos := 0 + END; + TextControllers.SetSelection(t, TextControllers.none, TextControllers.none); + globR := t.NewReader(globR); globR.SetPos(pos); + REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View); + IF ~globR.eot THEN + pos := globR.Pos(); v1(View).SetMode(v1(View).mode); + TextViews.ShowRange(t, pos, pos, TextViews.focusOnly) + ELSE + pos := 0; Dialog.Beep + END; + TextControllers.SetCaret(t, pos); + globR := NIL + END + END NextError; + + PROCEDURE ToggleCurrent*; + VAR c: TextControllers.Controller; t: TextModels.Model; v: Views.View; pos: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF (c # NIL) & c.HasCaret() THEN + t := c.text; pos := c.CaretPos(); + globR := t.NewReader(globR); globR.SetPos(pos); globR.ReadPrev; + v := globR.view; + IF (v # NIL) & (v IS View) THEN ToggleMode(v(View)) END; + TextViews.ShowRange(t, pos, pos, TextViews.focusOnly); + TextControllers.SetCaret(t, pos); + globR := NIL + END + END ToggleCurrent; + + + PROCEDURE SetDir* (d: Directory); + BEGIN + dir := d + END SetDir; + + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + thisEra := 1; + NEW(d); dir := d; stdDir := d + END Init; + +BEGIN + Init; Kernel.InstallCleaner(Cleanup) +CLOSE + Kernel.RemoveCleaner(Cleanup) +END DevMarkers. diff --git a/Trurl-based/Dev/Mod/Selectors.txt b/Trurl-based/Dev/Mod/Selectors.txt new file mode 100644 index 0000000..81d265f --- /dev/null +++ b/Trurl-based/Dev/Mod/Selectors.txt @@ -0,0 +1,411 @@ +MODULE DevSelectors; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Selectors.odc *) + (* DO NOT EDIT *) + + IMPORT + Ports, Stores, Models, Views, Controllers, Fonts, Properties, TextModels, TextViews, TextSetters; + + + CONST + left* = 1; middle* = 2; right* = 3; + + minVersion = 0; currentVersion = 0; + + changeSelectorsKey = "#Dev:Change Selectors"; + + + TYPE + Selector* = POINTER TO RECORD (Views.View) + position-: INTEGER; (* left, middle, right *) + leftHidden: TextModels.Model; (* valid iff (position = left) *) + rightHidden: TextModels.Model (* valid iff (position = left) *) + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + + VAR + dir-, stdDir-: Directory; + + + PROCEDURE (d: Directory) New* (position: INTEGER): Selector, NEW, ABSTRACT; + + + PROCEDURE GetFirst (selector: Selector; OUT first: Selector; OUT pos: INTEGER); + VAR c: Models.Context; rd: TextModels.Reader; v: Views.View; nest: INTEGER; + BEGIN + c := selector.context; first := NIL; pos := 0; + WITH c: TextModels.Context DO + IF selector.position = left THEN + first := selector + ELSE + rd := c.ThisModel().NewReader(NIL); rd.SetPos(c.Pos()); + nest := 1; pos := 1; rd.ReadPrevView(v); + WHILE (v # NIL) & (nest > 0) DO + WITH v: Selector DO + IF v.position = left THEN DEC(nest); + IF nest = 0 THEN first := v END + ELSIF v.position = right THEN INC(nest) + ELSIF nest = 1 THEN INC(pos) + END + ELSE + END; + rd.ReadPrevView(v) + END + END + ELSE (* selector not embedded in a text *) + END; + ASSERT((first = NIL) OR (first.position = left), 100) + END GetFirst; + + PROCEDURE GetNext (rd: TextModels.Reader; OUT next: Selector); + VAR nest: INTEGER; v: Views.View; + BEGIN + nest := 1; next := NIL; rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN INC(nest) + ELSIF nest = 1 THEN next := v; RETURN + ELSIF v.position = right THEN DEC(nest) + END + ELSE + END; + rd.ReadView(v) + END + END GetNext; + + PROCEDURE CalcSize (f: Selector; OUT w, h: INTEGER); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + c := f.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); + font := a.font + ELSE font := Fonts.dir.Default(); + END; + font.GetBounds(asc, dsc, fw); + h := asc + dsc; w := 3 * h DIV 4 + END CalcSize; + + PROCEDURE GetSection (first: Selector; rd: TextModels.Reader; n: INTEGER; OUT name: ARRAY OF CHAR); + VAR i, p0, p1: INTEGER; ch: CHAR; sel: Selector; + BEGIN + sel := first; + IF first.leftHidden.Length() > 0 THEN + rd := first.leftHidden.NewReader(rd); rd.SetPos(0); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL); + IF sel = NIL THEN INC(n) END; + p1 := rd.Pos() - 1 + END; + IF n >= 0 THEN + rd := first.context(TextModels.Context).ThisModel().NewReader(rd); + rd.SetPos(first.context(TextModels.Context).Pos() + 1); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL) OR (sel.position = right); + p1 := rd.Pos() - 1 + END; + IF (n >= 0) & (first.rightHidden.Length() > 0) THEN + rd := first.rightHidden.NewReader(rd); rd.SetPos(1); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL); + p1 := rd.Pos() - 1; + IF sel = NIL THEN p1 := first.rightHidden.Length() END + END; + IF n < 0 THEN + rd.SetPos(p0); rd.ReadChar(ch); i := 0; + WHILE (ch <= " ") & (rd.Pos() <= p1) DO rd.ReadChar(ch) END; + WHILE (i < LEN(name) - 1) & (rd.Pos() <= p1) & (ch # 0X) DO + IF ch >= " " THEN name[i] := ch; INC(i) END; + rd.ReadChar(ch) + END; + WHILE (i > 0) & (name[i - 1] = " ") DO DEC(i) END; + name[i] := 0X + ELSE + name := 7FX + "" + END + END GetSection; + + + PROCEDURE ChangeSelector (first: Selector; rd: TextModels.Reader; selection: INTEGER); + VAR pos, p0, len, s: INTEGER; text: TextModels.Model; sel: Selector; + BEGIN + text := rd.Base(); + pos := first.context(TextModels.Context).Pos() + 1; + (* expand *) + rd.SetPos(pos); + REPEAT GetNext(rd, sel) UNTIL (sel = NIL) OR (sel.position = right); + IF sel # NIL THEN + len := first.rightHidden.Length(); + IF len > 0 THEN text.Insert(rd.Pos() - 1, first.rightHidden, 0, len) END; + len := first.leftHidden.Length(); + IF len > 0 THEN text.Insert(pos, first.leftHidden, 0, len) END; + IF selection # 0 THEN (* collapse *) + rd.SetPos(pos); s := 0; + REPEAT GetNext(rd, sel); INC(s) UNTIL (s = selection) OR (sel = NIL) OR (sel.position = right); + IF (sel # NIL) & (sel.position = middle) THEN + first.leftHidden.Insert(0, text, pos, rd.Pos()); + rd.SetPos(pos); GetNext(rd, sel); + p0 := rd.Pos() - 1; + WHILE (sel # NIL) & (sel.position # right) DO GetNext(rd, sel) END; + IF sel # NIL THEN + first.rightHidden.Insert(0, text, p0, rd.Pos() - 1) + END + END + END + END; + rd.SetPos(pos) + END ChangeSelector; + + PROCEDURE ChangeThis ( + text: TextModels.Model; rd, rd1: TextModels.Reader; title: ARRAY OF CHAR; selection: INTEGER + ); + VAR v: Views.View; str: ARRAY 256 OF CHAR; + BEGIN + rd := text.NewReader(rd); + rd.SetPos(0); rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN + GetSection(v, rd1, 0, str); + IF str = title THEN + ChangeSelector(v, rd, selection) + END; + IF v.leftHidden.Length() > 0 THEN ChangeThis(v.leftHidden, NIL, rd1, title, selection) END; + IF v.rightHidden.Length() > 0 THEN ChangeThis(v.rightHidden, NIL, rd1, title, selection) END + END + ELSE + END; + rd.ReadView(v) + END + END ChangeThis; + + PROCEDURE Change* (text: TextModels.Model; title: ARRAY OF CHAR; selection: INTEGER); + VAR rd, rd1: TextModels.Reader; script: Stores.Operation; + BEGIN + rd := text.NewReader(NIL); + rd1 := text.NewReader(NIL); + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, changeSelectorsKey, script); + ChangeThis(text, rd, rd1, title, selection); + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END Change; + + PROCEDURE ChangeTo* (text: TextModels.Model; title, entry: ARRAY OF CHAR); + VAR rd, rd1: TextModels.Reader; str: ARRAY 256 OF CHAR; v: Views.View; sel: INTEGER; + BEGIN + rd := text.NewReader(NIL); + rd1 := text.NewReader(NIL); + rd.SetPos(0); rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN + GetSection(v, rd1, 0, str); + IF title = str THEN + sel := 0; + REPEAT + INC(sel); GetSection(v, rd1, sel, str) + UNTIL (str[0] = 7FX) OR (str = entry); + IF str[0] # 7FX THEN + Change(text, title, sel); + RETURN + END + END + END + ELSE + END; + rd.ReadView(v) + END + END ChangeTo; + + + PROCEDURE (selector: Selector) HandlePropMsg- (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; asc, w: INTEGER; + BEGIN + WITH msg: Properties.SizePref DO CalcSize(selector, msg.w, msg.h) + | msg: Properties.ResizePref DO msg.fixed := TRUE; + | msg: Properties.FocusPref DO msg.hotFocus := TRUE; + | msg: TextSetters.Pref DO c := selector.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); + a.font.GetBounds(asc, msg.dsc, w) + END + ELSE (*selector.HandlePropMsg^(msg);*) + END + END HandlePropMsg; + + PROCEDURE Track (selector: Selector; 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 := selector.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 (selector: Selector) HandleCtrlMsg* ( + f: Views.Frame; VAR msg: Views.CtrlMessage; VAR focus: Views.View + ); + VAR hit: BOOLEAN; sel, pos: INTEGER; text: TextModels.Model; title: ARRAY 256 OF CHAR; first: Selector; + BEGIN + WITH msg: Controllers.TrackMsg DO + IF selector.context IS TextModels.Context THEN + Track(selector, f, msg.x, msg.y, msg.modifiers, hit); + IF hit THEN + text := selector.context(TextModels.Context).ThisModel(); + GetFirst(selector, first, pos); + IF first # NIL THEN + GetSection(first, NIL, 0, title); + IF selector.position = middle THEN sel := pos ELSE sel := 0 END; + Change(text, title, sel); + text := selector.context(TextModels.Context).ThisModel(); + IF TextViews.FocusText() = text THEN + pos := selector.context(TextModels.Context).Pos(); + TextViews.ShowRange(text, pos, pos+1, TRUE) + END + END + END + END + | msg: Controllers.PollCursorMsg DO + msg.cursor := Ports.refCursor; + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (selector: Selector) Restore* (f: Views.Frame; l, t, r, b: INTEGER); + VAR w, h, d: INTEGER; + BEGIN + selector.context.GetSize(w, h); +(* + GetFirst(selector, first, pos); +*) + w := w - w MOD f.unit; d := 2 * f.dot; + f.DrawLine(d, d, w - d, d, d, Ports.grey25); + f.DrawLine(d, h - d, w - d, h - d, d, Ports.grey25); + IF selector.position # right THEN f.DrawLine(d, d, d, h - d, d, Ports.grey25) END; + IF selector.position # left THEN f.DrawLine(w - d, d, w - d, h - d, d, Ports.grey25) END + END Restore; + + PROCEDURE (selector: Selector) CopyFromSimpleView- (source: Views.View); + BEGIN + (* selector.CopyFrom^(source); *) + WITH source: Selector DO + selector.position := source.position; + IF source.leftHidden # NIL THEN + selector.leftHidden := TextModels.CloneOf(source.leftHidden); + selector.leftHidden.InsertCopy(0, source.leftHidden, 0, source.leftHidden.Length()) + END; + IF source.rightHidden # NIL THEN + selector.rightHidden := TextModels.CloneOf(source.rightHidden); + selector.rightHidden.InsertCopy(0, source.rightHidden, 0, source.rightHidden.Length()) + END + END + END CopyFromSimpleView; + + PROCEDURE (selector: Selector) InitContext* (context: Models.Context); + BEGIN + selector.InitContext^(context); + IF selector.position = left THEN + WITH context: TextModels.Context DO + IF selector.leftHidden = NIL THEN + selector.leftHidden := TextModels.CloneOf(context.ThisModel()); + Stores.Join(selector, selector.leftHidden); + END; + IF selector.rightHidden = NIL THEN + selector.rightHidden := TextModels.CloneOf(context.ThisModel()); + Stores.Join(selector, selector.rightHidden) + END + ELSE + END + END + END InitContext; + + PROCEDURE (selector: Selector) Internalize- (VAR rd: Stores.Reader); + VAR version: INTEGER; store: Stores.Store; + BEGIN + selector.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, currentVersion, version); + IF rd.cancelled THEN RETURN END; + rd.ReadInt(selector.position); + rd.ReadStore(store); + IF store # NIL THEN selector.leftHidden := store(TextModels.Model) + ELSE selector.leftHidden := NIL + END; + rd.ReadStore(store); + IF store # NIL THEN selector.rightHidden := store(TextModels.Model) + ELSE selector.rightHidden := NIL + END + END Internalize; + + PROCEDURE (selector: Selector) Externalize- (VAR wr: Stores.Writer); + BEGIN + selector.Externalize^(wr); + wr.WriteVersion(currentVersion); + wr.WriteInt(selector.position); + wr.WriteStore(selector.leftHidden); + wr.WriteStore(selector.rightHidden) + END Externalize; + + + PROCEDURE (d: StdDirectory) New (position: INTEGER): Selector; + VAR selector: Selector; + BEGIN + NEW(selector); + selector.position := position; + RETURN selector + END New; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d + END SetDir; + + + PROCEDURE DepositLeft*; + BEGIN + Views.Deposit(dir.New(left)) + END DepositLeft; + + PROCEDURE DepositMiddle*; + BEGIN + Views.Deposit(dir.New(middle)) + END DepositMiddle; + + PROCEDURE DepositRight*; + BEGIN + Views.Deposit(dir.New(right)) + END DepositRight; + + + PROCEDURE InitMod; + VAR d: StdDirectory; + BEGIN + NEW(d); dir := d; stdDir := d; + END InitMod; + +BEGIN + InitMod +END DevSelectors. + + + "Insert Left" "*F5" "DevSelectors.DepositLeft; StdCmds.PasteView" "StdCmds.PasteViewGuard" + "Insert Middle" "*F6" "DevSelectors.DepositMiddle; StdCmds.PasteView" "StdCmds.PasteViewGuard" + "Insert Right" "*F7" "DevSelectors.DepositRight; StdCmds.PasteView" "StdCmds.PasteViewGuard" diff --git a/Trurl-based/Dev/Rsrc/Errors.odc b/Trurl-based/Dev/Rsrc/Errors.odc new file mode 100644 index 0000000..b694ea0 Binary files /dev/null and b/Trurl-based/Dev/Rsrc/Errors.odc differ diff --git a/Trurl-based/Dev/Rsrc/Strings.odc b/Trurl-based/Dev/Rsrc/Strings.odc new file mode 100644 index 0000000..0924ba1 Binary files /dev/null and b/Trurl-based/Dev/Rsrc/Strings.odc differ diff --git a/Trurl-based/Dev/Rsrc/ru/Strings.odc b/Trurl-based/Dev/Rsrc/ru/Strings.odc new file mode 100644 index 0000000..dacc56f Binary files /dev/null and b/Trurl-based/Dev/Rsrc/ru/Strings.odc differ diff --git a/Trurl-based/Dev/Spec/ObjFile.odc b/Trurl-based/Dev/Spec/ObjFile.odc new file mode 100644 index 0000000..dd0bc71 Binary files /dev/null and b/Trurl-based/Dev/Spec/ObjFile.odc differ diff --git a/Trurl-based/Dev/Spec/PackedFiles.odc b/Trurl-based/Dev/Spec/PackedFiles.odc new file mode 100644 index 0000000..1759a83 Binary files /dev/null and b/Trurl-based/Dev/Spec/PackedFiles.odc differ diff --git a/Trurl-based/Dev/Spec/StoresFileFormat.odc b/Trurl-based/Dev/Spec/StoresFileFormat.odc new file mode 100644 index 0000000..4be52ee Binary files /dev/null and b/Trurl-based/Dev/Spec/StoresFileFormat.odc differ diff --git a/Trurl-based/Dev/Spec/SymFile.odc b/Trurl-based/Dev/Spec/SymFile.odc new file mode 100644 index 0000000..3bd1c13 Binary files /dev/null and b/Trurl-based/Dev/Spec/SymFile.odc differ diff --git a/Trurl-based/Dev0/Mod/CPB.odc b/Trurl-based/Dev0/Mod/CPB.odc new file mode 100644 index 0000000..6446649 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPB.odc differ diff --git a/Trurl-based/Dev0/Mod/CPB.txt b/Trurl-based/Dev0/Mod/CPB.txt new file mode 100644 index 0000000..33cf1d1 --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPB.txt @@ -0,0 +1,2251 @@ +MODULE Dev0CPB; + + (* THIS IS TEXT COPY OF CPB.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems, Robert Campbell" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPT := Dev0CPT, DevCPM := Dev0CPM; + + CONST + (* symbol values or ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; size = 37; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13; + + AssertTrap = 0; (* default trap number *) + + covarOut = FALSE; + + + VAR + typSize*: PROCEDURE(typ: DevCPT.Struct); + zero, one, two, dummy, quot: DevCPT.Const; + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node; + VAR node: DevCPT.Node; typ: DevCPT.Struct; + BEGIN + typ := obj.typ; + CASE obj.mode OF + Var: + node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0) + | VarPar: + node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar; + | Con: + node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst(); + node.conval^ := obj.conval^ (* string is not copied, only its ref *) + | Typ: + node := DevCPT.NewNode(Ntype) + | LProc..IProc, TProc: + node := DevCPT.NewNode(Nproc) + ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp + END ; + node.obj := obj; node.typ := typ; + RETURN node + END NewLeaf; + + PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := DevCPT.notyp; + node.left := x; node.right := y; x := node + END Construct; + + PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node); + BEGIN + IF x = NIL THEN x := y ELSE last.link := y END ; + WHILE y.link # NIL DO y := y.link END ; + last := y + END Link; + + PROCEDURE BoolToInt(b: BOOLEAN): INTEGER; + BEGIN + IF b THEN RETURN 1 ELSE RETURN 0 END + END BoolToInt; + + PROCEDURE IntToBool(i: INTEGER): BOOLEAN; + BEGIN + IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END + END IntToBool; + + PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x + END NewBoolConst; + + PROCEDURE OptIf*(VAR x: DevCPT.Node); (* x.link = NIL *) + VAR if, pred: DevCPT.Node; + BEGIN + if := x.left; + WHILE if.left.class = Nconst DO + IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN + ELSIF if.link = NIL THEN x := x.right; RETURN + ELSE if := if.link; x.left := if + END + END ; + pred := if; if := if.link; + WHILE if # NIL DO + IF if.left.class = Nconst THEN + IF IntToBool(if.left.conval.intval) THEN + pred.link := NIL; x.right := if.right; RETURN + ELSE if := if.link; pred.link := if + END + ELSE pred := if; if := if.link + END + END + END OptIf; + + PROCEDURE Nil*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x + END Nil; + + PROCEDURE EmptySet*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp; + x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x + END EmptySet; + + PROCEDURE MarkAsUsed (node: DevCPT.Node); + VAR c: BYTE; + BEGIN + c := node.class; + WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END; + IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END + END MarkAsUsed; + + + PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object); + VAR n: DevCPT.Name; o: DevCPT.Object; + BEGIN + n := "@@ "; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *) + obj.mode := Var; obj.typ := typ; + o := DevCPT.topScope.scope; + IF o = NIL THEN DevCPT.topScope.scope := obj + ELSE + WHILE o.link # NIL DO o := o.link END; + o.link := obj + END + END GetTempVar; + + + (* ---------- constant operations ---------- *) + + PROCEDURE Log (x: DevCPT.Node): INTEGER; + VAR val, exp: INTEGER; + BEGIN + exp := 0; + IF x.typ.form = Int64 THEN + RETURN -1 + ELSE + val := x.conval.intval; + IF val > 0 THEN + WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END + END; + IF val # 1 THEN exp := -1 END + END; + RETURN exp + END Log; + + PROCEDURE Floor (x: REAL): REAL; + VAR y: REAL; + BEGIN + IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x + ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN + y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0); + RETURN SHORT(ENTIER(x - y)) + y + ELSE RETURN SHORT(ENTIER(x)) + END + END Floor; + + PROCEDURE SetToInt (s: SET): INTEGER; + VAR x, i: INTEGER; + BEGIN + i := 31; x := 0; + IF 31 IN s THEN x := -1 END; + WHILE i > 0 DO + x := x * 2; DEC(i); + IF i IN s THEN INC(x) END + END; + RETURN x + END SetToInt; + + PROCEDURE IntToSet (x: INTEGER): SET; + VAR i: INTEGER; s: SET; + BEGIN + i := 0; s := {}; + WHILE i < 32 DO + IF ODD(x) THEN INCL(s, i) END; + x := x DIV 2; INC(i) + END; + RETURN s + END IntToSet; + + PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct); + CONST MAXL = 9223372036854775808.0; (* 2^63 *) + BEGIN + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF form IN intSet THEN + IF x.realval = 0 THEN typ := DevCPT.int32typ + ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ + ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ + END + ELSIF form IN realSet THEN (* SR *) + typ := DevCPT.real64typ + ELSIF form IN charSet THEN + IF x.intval <= 255 THEN typ := DevCPT.char8typ + ELSE typ := DevCPT.char16typ + END + ELSE typ := DevCPT.undftyp + END + END GetConstType; + + PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT); + VAR type: DevCPT.Struct; + BEGIN + GetConstType(x, form, errno, type); + IF ~DevCPT.Includes(form, type.form) + & ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + & ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + & ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN + err(errno); x.intval := 1; x.realval := 0 + END +(* + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval)) + OR (form = Int32) & (x.realval # 0) + OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535)) + OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255)) + OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN + err(errno); x.intval := 1; x.realval := 0 + END +*) + END CheckConstType; + + PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER); + VAR sr: SHORTREAL; + BEGIN + IF from = Set THEN + x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {}; + ELSIF from IN intSet + charSet THEN + IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval) + ELSIF to IN intSet THEN CheckConstType(x, to, 203) + ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc + ELSE (*to IN charSet*) CheckConstType(x, to, 220) + END + ELSIF from IN realSet THEN + IF to IN realSet THEN CheckConstType(x, to, 203); + IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *) + ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203) + END + END + END ConvConst; + + PROCEDURE Prepare (x: DevCPT.Const); + VAR r: REAL; + BEGIN + x.realval := x.realval + x.intval DIV 32768 * 32768; + x.intval := x.intval MOD 32768; + r := Floor(x.realval / 4096) * 4096; + x.intval := x.intval + SHORT(ENTIER(x.realval - r)); + x.realval := r + (* ABS(x.intval) < 2^15 & ABS(x.realval) MOD 2^12 = 0 *) + END Prepare; + + PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval + y.intval; z.realval := x.realval + y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212) + ELSE z.realval := x.realval + y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 206, type) + END AddConst; + + PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *) + BEGIN + IF type.form IN intSet THEN Prepare(y); z.intval := -y.intval; z.realval := -y.realval + ELSIF type.form IN realSet THEN z.realval := -y.realval + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END NegateConst; + + PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval - y.intval; z.realval := x.realval - y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = y.realval) THEN err(212) + ELSE z.realval := x.realval - y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END SubConst; + + PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval; + z.intval := x.intval * y.intval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212) + ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212) + ELSE z.realval := x.realval * y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END MulConst; + + PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *) + BEGIN + IF type.form IN realSet THEN + IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212) + ELSIF (ABS(x.realval) = DevCPM.InfReal) & (ABS(y.realval) = DevCPM.InfReal) THEN err(212) + ELSE z.realval := x.realval / y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END DivConst; + + PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct); + (* x := x DIV y | x MOD y *) + BEGIN + IF type.form IN intSet THEN + IF y.realval + y.intval # 0 THEN + Prepare(x); Prepare(y); + quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval)); + quot.intval := 0; Prepare(quot); + x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval; + x.intval := x.intval - quot.intval * y.intval; + IF y.realval + y.intval > 0 THEN + WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + ELSE + WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + END; + IF div THEN x.realval := quot.realval; x.intval := quot.intval END; + GetConstType(x, type.form, 204, type) + ELSE err(205) + END + ELSE HALT(100) + END + END DivModConst; + + PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0 + | Real32, Real64: res := x.realval = y.realval + | Set: res := x.setval = y.setval + | String8, String16, Comp (* guid *): res := x.ext^ = y.ext^ + | NilTyp, Pointer, ProcTyp: res := x.intval = y.intval + END; + RETURN res + END EqualConst; + + PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Byte, Char8..Int32, Char16: res := x.intval < y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0 + | Real32, Real64: res := x.realval < y.realval + | String8, String16: res := x.ext^ < y.ext^ + | Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108) + END; + RETURN res + END LessConst; + + PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0 OR x = (-0.0) *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Int8..Int32: res := x.intval < 0 + | Int64: Prepare(x); res := x.realval + x.intval < 0 + | Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.) + END; + RETURN res + END IsNegConst; + + + PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x + END NewIntConst; + + PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x + END NewLargeIntConst; + + PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc; + IF typ = NIL THEN typ := DevCPT.real64typ END; + x.typ := typ; + RETURN x + END NewRealConst; + + PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node; + VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + IF lstr # NIL THEN + x.typ := DevCPT.string16typ; + NEW(ext, 3 * len); i := 0; j := 0; + REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0; + x.conval.ext := ext + ELSE + x.typ := DevCPT.string8typ; x.conval.ext := str + END; + x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len; + RETURN x + END NewString; + + PROCEDURE CharToString8(n: DevCPT.Node); + VAR ch: SHORTCHAR; + BEGIN + n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2); + IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ; + n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString8; + + PROCEDURE CharToString16 (n: DevCPT.Node); + VAR ch, ch1: SHORTCHAR; i: INTEGER; + BEGIN + n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4); + IF n.conval.intval = 0 THEN + n.conval.ext[0] := 0X; n.conval.intval2 := 1 + ELSE + i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i); + n.conval.ext[i] := 0X; n.conval.intval2 := 2 + END; + n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString16; + + PROCEDURE String8ToString16 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string16typ; ext := n.conval.ext; + NEW(new, 2 * n.conval.intval2); i := 0; j := 0; + REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String8ToString16; + + PROCEDURE String16ToString8 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string8typ; ext := n.conval.ext; + NEW(new, n.conval.intval2); i := 0; j := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String16ToString8; + + PROCEDURE StringToGuid (VAR n: DevCPT.Node); + BEGIN + ASSERT((n.class = Nconst) & (n.typ.form = String8)); + IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END; + n.typ := DevCPT.guidtyp + END StringToGuid; + + PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT); + VAR ntyp: DevCPT.Struct; + BEGIN + ntyp := n.typ; + IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n) + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN + IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *) + ELSE err(e) + END + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN + IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n) + ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN + (* ok *) + ELSE err(e) + END + ELSE err(e) + END + END CheckString; + + + PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := typ; + node.left := x; node.right := y; x := node + END BindNodes; + + PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst)) + OR (x.typ.form IN {String8, String16}) + END NotVar; + + + PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL; + BEGIN f := x.typ.form; g := typ.form; + IF x.class = Nconst THEN + IF g = String8 THEN + IF f = String16 THEN String16ToString8(x) + ELSIF f IN charSet THEN CharToString8(x) + ELSE typ := DevCPT.undftyp + END + ELSIF g = String16 THEN + IF f = String8 THEN String8ToString16(x) + ELSIF f IN charSet THEN CharToString16(x) + ELSE typ := DevCPT.undftyp + END + ELSE ConvConst(x.conval, f, g) + END; + x.obj := NIL + ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g)) + THEN + (* don't create new node *) + IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END + ELSE + IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *) + Convert(x.left, typ); Convert(x.right, typ) + ELSE + node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node; + END + END; + x.typ := typ + END Convert; + + PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *) + VAR f, g: INTEGER; new: DevCPT.Struct; + BEGIN + f := left.typ.form; g := right.typ.form; new := left.typ; + IF f IN intSet + realSet THEN + IF g IN intSet + realSet THEN + IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst) + (* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(right.conval.realval) = DevCPM.InfReal)) *) + OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst) + (* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN + new := DevCPT.real32typ (* SR *) + ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ + ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *) + ELSIF op = slash THEN new := DevCPT.real64typ + ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ + ELSE new := DevCPT.int32typ + END + ELSE err(100) + END + ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN + IF f = String8 THEN StringToGuid(left) END; + IF g = String8 THEN StringToGuid(right) END; + IF left.typ # right.typ THEN err(100) END; + f := Comp + ELSIF f IN charSet + {String8, String16} THEN + IF g IN charSet + {String8, String16} THEN + IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN + new := DevCPT.string16typ + ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ + ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ + ELSIF op = plus THEN + IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ + ELSE new := DevCPT.string8typ + END + END; + IF (new.form IN {String8, String16}) + & ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst)) + THEN + err(100) + END + ELSE err(100) + END + ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN + IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp) + & ~((f = Pointer) & (g = Pointer) + & (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END + ELSIF f # g THEN err(100) + END; + IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN + IF g # new.form THEN Convert(right, new) END; + IF f # new.form THEN Convert(left, new) END + END + END Promote; + + PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *) + VAR ft, at: DevCPT.Struct; + BEGIN + WHILE fp # NIL DO + IF ap # NIL THEN + ft := fp.typ; at := ap.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *) + IF ~DevCPT.EqualType(ft, at) + OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis) + OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ; + ap := ap.link + ELSE err(116) + END; + fp := fp.link + END; + IF ap # NIL THEN err(116) END + END CheckParameters; + + PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node); + VAR ityp, ntyp: DevCPT.Struct; + BEGIN + ntyp := newPar.typ.BaseTyp; + IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN + IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev) + THEN (* ok *) + ELSE err(168) + END + ELSIF ntyp.extlev = 0 THEN (* ok *) + ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN + IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END + ELSE err(168) + END + END CheckNewParamPair; + + + PROCEDURE DeRef*(VAR x: DevCPT.Node); + VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF typ.form = Pointer THEN + btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN + btyp.pbused := TRUE + END ; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 0 + ELSE err(84) + END + END DeRef; + + PROCEDURE StrDeref*(VAR x: DevCPT.Node); + VAR typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ + ELSE btyp := DevCPT.string16typ + END; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 1 + ELSE err(90) + END + END StrDeref; + + PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; + BEGIN + f := y.typ.form; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79) + ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ; + IF f = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.typ.comp = Array THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END + ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END + ELSE err(82); typ := DevCPT.undftyp + END ; + BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly + END Index; + + PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object); + BEGIN (*x.typ.comp = Record*) + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ; + IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN + BindNodes(Nfield, y.typ, x, NIL); x.obj := y; + x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0)) + ELSE err(83); x.typ := DevCPT.undftyp + END + END Field; + + PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN); + + PROCEDURE GTT(t0, t1: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN + IF ~guard THEN x := NewBoolConst(TRUE) END + ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint) + OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN + IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly + ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node + END + ELSE err(85) + END + END GTT; + + BEGIN + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112) + ELSIF x.typ.form = Pointer THEN + IF x.typ = DevCPT.sysptrtyp THEN + IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF x.typ.BaseTyp.comp # Record THEN err(85) + ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN + GTT(x.typ, obj.typ) + ELSE err(87) + END ; + IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END + END TypTest; + + PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; k: INTEGER; + BEGIN f := x.typ.form; + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (f IN intSet) & (y.typ.form = Set) THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202) + ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE err(92) + END ; + x.typ := DevCPT.booltyp + END In; + + PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ; + node.left := z; RETURN node + END NewOp; + + BEGIN z := x; + IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *) + ELSE + typ := z.typ; f := typ.form; + CASE op OF + | not: + IF f = Bool THEN + IF z.class = Nconst THEN + z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + | plus: + IF ~(f IN intSet + realSet) THEN err(96) END + | minus: + IF f IN intSet + realSet + {Set} THEN + IF z.class = Nconst THEN + IF f = Set THEN z.conval.setval := -z.conval.setval + ELSE NegateConst(z.conval, z.conval, z.typ) + END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(97) + END + | abs: + IF f IN intSet + realSet THEN + IF z.class = Nconst THEN + IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(111) + END + | cap: + IF f IN charSet THEN + IF z.class = Nconst THEN + IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END; + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z.typ := DevCPT.char8typ + END + | odd: + IF f IN intSet THEN + IF z.class = Nconst THEN + DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *) + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z.typ := DevCPT.booltyp + | adr: (*ADR*) + IF z.class = Nproc THEN + IF z.obj.mnolev > 0 THEN err(73) + ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc + END; + z := NewOp(op, typ, z) + ELSIF z.class = Ntype THEN + IF z.obj.typ.untagged THEN err(111) END; + z := NewOp(op, typ, z) + ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN + z := NewOp(op, typ, z) + ELSE err(127) + END ; + z.typ := DevCPT.int32typ + | typfn, size: (*TYP, SIZE*) + z := NewOp(op, typ, z); + z.typ := DevCPT.int32typ + | cc: (*SYSTEM.CC*) + IF (f IN intSet) & (z.class = Nconst) THEN + IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN + z := NewOp(op, typ, z) + ELSE err(219) + END + ELSE err(69) + END; + z.typ := DevCPT.booltyp + END + END; + x := z + END MOp; + + PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node); + VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct; + BEGIN + f := x.typ.form; + IF f = y.typ.form THEN + xval := x.conval; yval := y.conval; + CASE op OF + | times: + IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval * yval.setval + ELSIF f # Undef THEN err(101) + END + | slash: + IF f IN realSet THEN DivConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval / yval.setval + ELSIF f # Undef THEN err(102) + END + | div: + IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ) + ELSIF f # Undef THEN err(103) + END + | mod: + IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ) + ELSIF f # Undef THEN err(104) + END + | and: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval)) + ELSE err(94) + END + | plus: + IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval + yval.setval + ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN + NEW(ext, LEN(xval.ext^) + LEN(yval.ext^)); + i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END; + j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END; + ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1) + ELSIF f # Undef THEN err(105) + END + | minus: + IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval - yval.setval + ELSIF f # Undef THEN err(106) + END + | min: + IF f IN intSet + realSet THEN + IF LessConst(yval, xval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | max: + IF f IN intSet + realSet THEN + IF LessConst(xval, yval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | or: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval)) + ELSE err(95) + END + | eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + | leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + END + ELSE err(100) + END; + x.obj := NIL + END ConstOp; + + PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ; + node.left := x; node.right := y; x := node + END NewOp; + + BEGIN z := x; + IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSE + Promote(z, y, op); + IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y) + ELSE + typ := z.typ; f := typ.form; g := y.typ.form; + CASE op OF + | times: + do := TRUE; + IF f IN intSet THEN + IF z.class = Nconst THEN + IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y + ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE + ELSE val := Log(z); + IF val >= 0 THEN + t := y; y := z; z := t; + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + ELSIF y.class = Nconst THEN + IF EqualConst(y.conval, one, f) THEN do := FALSE + ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + END + ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | slash: + IF f IN realSet THEN (* OK *) + ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y) + | div: + do := TRUE; + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSIF EqualConst(y.conval, one, f) THEN do := FALSE + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | mod: + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSE val := Log(y); + IF val >= 0 THEN + op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y); + | and: + IF f = Bool THEN + IF z.class = Nconst THEN + IF IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp + END + | plus: + IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END; + do := TRUE; + IF f IN intSet THEN + IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END + ELSIF f IN {String8, String16} THEN + IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END; + IF do THEN + IF z.class = Ndop THEN + t := z; WHILE t.right.class = Ndop DO t := t.right END; + IF (t.right.class = Nconst) & (y.class = Nconst) THEN + ConstOp(op, t.right, y); do := FALSE + ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE + ELSE + NewOp(op, typ, t.right, y); do := FALSE + END + ELSE + IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE + END + END + END + END ; + IF do THEN NewOp(op, typ, z, y) END; + | minus: + IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END; + IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y) + END; + | min, max: + IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END; + NewOp(op, typ, z, y); + | or: + IF f = Bool THEN + IF z.class = Nconst THEN + IF ~IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp + END + | eql, neq, lss, leq, gtr, geq: + IF f IN {String8, String16} THEN + IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN + z := z.left; y := y.left (* remove LONG on both sides *) + ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *) + y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0 + ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *) + z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0 + END; + typ := DevCPT.booltyp + ELSIF (f IN {Undef, Char8..Real64, Char16, Int64}) + OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN + typ := DevCPT.booltyp + ELSE err(107); typ := DevCPT.undftyp + END; + NewOp(op, typ, z, y) + END + END + END; + x := z + END Op; + + PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR k, l: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END + END ; + IF y.class = Nconst THEN + l := y.conval.intval; + IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END + END ; + IF (x.class = Nconst) & (y.class = Nconst) THEN + IF k <= l THEN + x.conval.setval := {k..l} + ELSE err(201); x.conval.setval := {l..k} + END ; + x.obj := NIL + ELSE BindNodes(Nupto, DevCPT.settyp, x, y) + END + ELSE err(93) + END ; + x.typ := DevCPT.settyp + END SetRange; + + PROCEDURE SetElem*(VAR x: DevCPT.Node); + VAR k: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END; + IF x.typ.form IN intSet THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k} + ELSE err(202) + END ; + x.obj := NIL + ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit + END ; + ELSE err(93) + END; + x.typ := DevCPT.settyp + END SetElem; + + PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node); + (* x := y, checks assignment compatibility *) + VAR f, g: SHORTINT; y, b: DevCPT.Struct; + BEGIN + y := ynode.typ; f := x.form; g := y.form; + IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + CASE f OF + | Undef, String8, String16, Byte: + | Bool, Set: + IF g # f THEN err(113) END + | Int8, Int16, Int32, Int64, Real32, Real64: (* SR *) + IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN + IF ynode.class = Nconst THEN Convert(ynode, x) + ELSIF ~DevCPT.Includes(f, g) THEN err(113) + END + ELSE err(113) + END +(* + IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN + err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END +*) + | Char8, Char16: + IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END + | Pointer: + b := x.BaseTyp; + IF DevCPT.Extends(y, x) + OR (g = NilTyp) + OR (g = Pointer) + & ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp)) + THEN (* ok *) + ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *) + IF ynode.class = Nconst THEN CheckString(ynode, b, 113) + ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113) + END + ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *) + IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113) + ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113) + END + ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8})) + THEN + IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END + ELSE err(113) + END + | ProcTyp: + IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *) + ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN + IF ynode.obj.mode = LProc THEN + IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END + END; + IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN + IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE) + ELSE err(117) + END + ELSE err(113) + END + ELSE err(113) + END + | NoTyp, NilTyp: err(113) + | Comp: + x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x.comp = Record THEN + IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END + ELSIF g IN {Char8, Char16, String8, String16} THEN + IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ) + ELSE CheckString(ynode, x, 113); + END; + IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN + err(114) + END + ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *) + ELSE err(113) + END + END + END CheckAssign; + + PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *) + BEGIN + ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16})); + IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *) + Index(x, NewIntConst(0)); + str.typ := x.typ; str.conval.intval := 0; + END; + BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign + END AssignString; + + PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN); + BEGIN + IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ; + IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *) + IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END + END CheckLeaf; + + PROCEDURE CheckOldType (x: DevCPT.Node); + BEGIN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN + err(198) + END + END CheckOldType; + + PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *) + VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node; + BEGIN x := par0; f := x.typ.form; + CASE fctno OF + haltfn: (*HALT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(218) + END + ELSIF (DevCPM.java IN DevCPM.options) + & ((x.class = Ntype) OR (x.class = Nvar)) + & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(69) + END ; + x.typ := DevCPT.notyp + | newfn: (*NEW*) + typ := DevCPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = Pointer THEN + IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x.readonly THEN err(76) + ELSIF (x.typ.BaseTyp.attribute = absAttr) + OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + f := x.typ.BaseTyp.comp; + IF f IN {Record, DynArr, Array} THEN + IF f = DynArr THEN typ := x.typ.BaseTyp END ; + BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn + ELSE err(111) + END + ELSE err(111) + END ; + x.typ := typ + | absfn: (*ABS*) + MOp(abs, x) + | capfn: (*CAP*) + MOp(cap, x) + | ordfn: (*ORD*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Set THEN Convert(x, DevCPT.int32typ) + ELSE err(111) + END + | bitsfn: (*BITS*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp) + ELSE err(111) + END + | entierfn: (*ENTIER*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | lentierfcn: (* LENTIER *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | oddfn: (*ODD*) + MOp(odd, x) + | minfn: (*MIN*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(FALSE) + | Char8: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Int8: x := NewIntConst(-128) + | Int16: x := NewIntConst(-32768) + | Int32: x := NewIntConst(-2147483648) + | Int64: x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *) + | Set: x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | maxfn: (*MAX*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(TRUE) + | Char8: x := NewIntConst(0FFH); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ + | Int8: x := NewIntConst(127) + | Int16: x := NewIntConst(32767) + | Int32: x := NewIntConst(2147483647) + | Int64: x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *) + | Set: x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | chrfn: (*CHR*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | lchrfn: (* LCHR *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | shortfn: (*SHORT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int16 THEN Convert(x, DevCPT.int8typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ) + ELSIF f = String16 THEN Convert(x, DevCPT.string8typ) + ELSE err(111) + END + END + | longfn: (*LONG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ) + ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ) + ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ) + ELSIF f = String8 THEN Convert(x, DevCPT.string16typ) + ELSE err(111) + END + END + | incfn, decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF ~(f IN intSet) THEN err(111) + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | inclfn, exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | lenfn: (*LEN*) + IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *) + (* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.class = Nconst THEN + IF x.typ.form = Char8 THEN CharToString8(x) + ELSIF x.typ.form = Char16 THEN CharToString16(x) + END + END; + IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END + END + | copyfn: (*COPY*) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END + ELSE err(111); x.typ := DevCPT.int32typ + END + | adrfn: (*ADR*) + IF x.class = Ntype THEN CheckOldType(x) END; + CheckLeaf(x, FALSE); MOp(adr, x) + | typfn: (*TYP*) + CheckLeaf(x, FALSE); + IF x.class = Ntype THEN + CheckOldType(x); + IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(adr, x) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(typfn, x) + END + | sizefn: (*SIZE*) + IF x.class # Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN + CheckOldType(x); x.typ.pvused := TRUE; + IF typSize # NIL THEN + typSize(x.typ); x := NewIntConst(x.typ.size) + ELSE + MOp(size, x) + END + ELSE err(111); x := NewIntConst(1) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ) + ELSIF f # Int32 THEN err(111) + END + | ccfn: (*SYSTEM.CC*) + MOp(cc, x) + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111) + END + | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END + | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN intSet) & (x.class = Nconst) THEN + IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220) + END + ELSE err(69) + END + | valfn: (*SYSTEM.VAL*) + IF x.class # Ntype THEN err(110) + ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111) + ELSE CheckOldType(x) + END + | assertfn: (*ASSERT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(not, x) + END + | validfn: (* VALID *) + IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN + MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil()) + ELSE err(111) + END; + x.typ := DevCPT.booltyp + | iidfn: (* COM.IID *) + IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x) + ELSE + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN + IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END + ELSE err(111) + END; + x.class := Nconst; x.typ := DevCPT.guidtyp + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f # Pointer THEN err(111) + END + END ; + par0 := x + END StPar0; + + PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE); + (* x: second parameter of standard proc *) + VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node; + + PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.subcl := subcl; + node.left := left; node.right := right; RETURN node + END NewOp; + + BEGIN p := par0; f := x.typ.form; + CASE fctno OF + incfn, decfn: (*INC DEC*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp + ELSE + IF f # p.typ.form THEN + IF f IN intSet THEN Convert(x, p.typ) + ELSE err(111) + END + END ; + p := NewOp(Nassign, fctno, p, x); + p.typ := DevCPT.notyp + END + | inclfn, exclfn: (*INCL, EXCL*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202) + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | lenfn: (*LEN*) + IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69) + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + L := SHORT(x.conval.intval); typ := p.typ; + WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132) + ELSE x.obj := NIL; + IF typ.comp = DynArr THEN + WHILE p.class = Nindex DO + p := p.left; INC(x.conval.intval) (* possible side effect ignored *) + END; + p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ + ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ + END + END + END + | copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF x.readonly THEN err(76) + ELSE + CheckString(p, x.typ, 111); t := x; x := p; p := t; + IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x) + ELSE p := NewOp(Nassign, copyfn, p, x) + END + END ; + p.typ := DevCPT.notyp; MarkAsUsed(x) + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208) + ELSIF (p.class = Nconst) & (x.class = Nconst) THEN + n := x.conval.intval; + IF n > 0 THEN + WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END + ELSE + WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END + END; + p.obj := NIL + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ + END + ELSE err(111) + END + | minfn: (*MIN*) + IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END + | maxfn: (*MAX*) + IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END + | newfn: (*NEW(p, x...)*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp = DynArr THEN + IF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) + & (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END + ELSE err(111) + END ; + p.right := x; p.typ := p.typ.BaseTyp + ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN + typ := p.left.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF typ.sysflag = interface THEN + typ := x.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF (f = Pointer) & (typ.sysflag = interface) THEN + p.right := x + ELSE err(169) + END + ELSE err(64) + END + ELSE err(111) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END; + p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp + ELSE err(111) + END + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet) THEN err(111) + ELSE + IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; + p.typ := p.left.typ + END + | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN + IF (fctno = getfn) OR (fctno = getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | bitfn: (*SYSTEM.BIT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + p := NewOp(Ndop, bit, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.booltyp + | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *) + ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN + typ := x.typ; + WHILE typ.comp = DynArr DO typ := typ.BaseTyp END; + tp1 := p.typ; + WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END; + IF typ.size # tp1.size THEN err(115) END + ELSE err(115) + END + ELSIF p.typ.comp = DynArr THEN err(115) + ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN + i := 0; n := 0; + WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END; + x := NewIntConst(n) + ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111) + END ; + IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *) + ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet)) + OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN + t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t + ELSE x.readonly := FALSE + END ; + x.typ := p.typ; p := x + | movefn: (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END ; + p.link := x + | assertfn: (*ASSERT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(218) + END + ELSIF + (DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(69) + END; + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp + END; + p.link := x + ELSE err(64) + END ; + par0 := p + END StPar1; + + PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT); + (* x: n+1-th param of standard proc *) + VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct; + BEGIN p := par0; f := x.typ.form; + IF fctno = newfn THEN (*NEW(p, ..., x...*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp # DynArr THEN err(64) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END; + node := p.right; WHILE node.link # NIL DO node := node.link END; + node.link := x; p.typ := p.typ.BaseTyp + ELSE err(111) + END + ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p; + node.left := p.link; p.link := x; p := node + ELSE err(111) + END ; + p.typ := DevCPT.notyp + ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN + IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END; + IF x.readonly THEN err(76) END; + CheckNewParamPair(x, p.link); + MarkAsUsed(x); + node := DevCPT.NewNode(Ndop); node.subcl := queryfn; + node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node + ELSE err(111) + END; + p.typ := DevCPT.booltyp + ELSE err(64) + END ; + par0 := p + END StParN; + + PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT); + VAR dim: SHORTINT; x, p: DevCPT.Node; + BEGIN p := par0; + IF fctno <= ashfn THEN + IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN + IF p.typ.comp = DynArr THEN err(65) END ; + p.typ := DevCPT.notyp + ELSIF (fctno = minfn) OR (fctno = maxfn) THEN + IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END; + p.hint := 0 + ELSIF fctno <= sizefn THEN (* 1 param *) + IF parno < 1 THEN err(65) END + ELSE (* more than 1 param *) + IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ + ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) + IF p.typ.form IN {String8, String16} THEN + IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1) + ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *) + StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ + ELSE + WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END; + IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END; + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len + END + ELSIF p.typ.comp = DynArr THEN dim := 0; + WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len + ELSE + p := NewIntConst(p.typ.n) + END + ELSIF parno < 2 THEN err(65) + END + END + ELSIF fctno = assertfn THEN + IF parno = 1 THEN x := NIL; + BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap)); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + ELSIF parno < 1 THEN err(65) + END + ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN + IF parno < 1 THEN err(65) END + ELSIF fctno < validfn THEN (*SYSTEM*) + IF (parno < 1) OR + (fctno > ccfn) & (parno < 2) OR + (fctno = movefn) & (parno < 3) THEN err(65) + END + ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN + IF parno < 2 THEN err(65) END + ELSE (* COM *) + IF fctno = queryfn THEN + IF parno < 3 THEN err(65) END + ELSE + IF parno < 1 THEN err(65) END + END + END ; + par0 := p + END StFct; + + PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN); + (* check array compatibility *) + VAR atyp: DevCPT.Struct; + BEGIN (* ftyp.comp = DynArr *) + atyp := ap.typ; + IF atyp.form IN {Char8, Char16, String8, String16} THEN + IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ) + ELSE CheckString(ap, ftyp, 67) + END + ELSE + WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END; + IF ftyp.comp = DynArr THEN err(67) + ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *) + ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66) + END + END + END DynArrParCheck; + + PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object); + BEGIN + IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN + fpar := x.obj.link; + IF x.obj.mode = TProc THEN + IF fpar.typ.form = Pointer THEN + IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END + END; + fpar := fpar.link + END + ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN + fpar := x.typ.link + ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp + END + END PrepCall; + + PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *) + VAR at, ft: DevCPT.Struct; + BEGIN + at := ap.typ; ft := fp.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ft.form # Undef THEN + IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END; + IF fp.mode = VarPar THEN + IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *) + ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *) + ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN + (* ok *) + ELSE + IF fp.vis = inPar THEN + IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN + StringToGuid(ap); at := ap.typ +(* + ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp)) + & ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *) + ELSIF NotVar(ap) THEN err(122) +*) + END; + IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END + ELSE + IF NotVar(ap) THEN err(122) + ELSIF ap.readonly THEN err(76) + ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN + err(167) + ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE) + END + END; + IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar) + ELSIF ODD(fp.sysflag DIV newBit) THEN + IF ~DevCPT.Extends(at, ft) THEN err(123) END + ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *) + ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *) + ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *) + ELSIF fp.vis = inPar THEN CheckAssign(ft, ap) + ELSIF ~DevCPT.EqualType(ft, at) THEN err(123) + END + END + ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE) + ELSE CheckAssign(ft, ap) + END + END + END Param; + + PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN); + VAR scope: DevCPT.Object; + BEGIN + scope := DevCPT.topScope; + WHILE dlev > 0 DO DEC(dlev); + INCL(scope.link.conval.setval, slNeeded); + scope := scope.left + END; + IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *) + END StaticLink; + + PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object); + VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE; + BEGIN + IF x.class = Nproc THEN typ := x.typ; + lev := x.obj.mnolev; + IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *) + IF x.obj.mode = IProc THEN err(121) END + ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ; + x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link + ELSE typ := x.typ.BaseTyp + END ; + BindNodes(Ncall, typ, x, apar); x.obj := fp + END Call; + + PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object); + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc; + x.left := procdec; x.right := stat; procdec := x + END Enter; + + PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object); + VAR node: DevCPT.Node; + BEGIN + IF proc = NIL THEN (* return from module *) + IF x # NIL THEN err(124) END + ELSE + IF x # NIL THEN CheckAssign(proc.typ, x) + ELSIF proc.typ # DevCPT.notyp THEN err(124) + END + END ; + node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node + END Return; + + PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR z: DevCPT.Node; + BEGIN + IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ; + CheckAssign(x.typ, y); + IF x.readonly THEN err(76) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y) + ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign + END + END Assign; + + PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ninittd); node.typ := typ; + node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos; + IF inittd = NIL THEN inittd := node ELSE last.link := node END ; + last := node + END Inittd; + + (* handling of temporary variables for string operations *) + + PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN; + BEGIN + IF right.class = Nconst THEN + RETURN FALSE + ELSIF (right.class = Ndop) & (right.subcl = plus) THEN + RETURN Overlap(left, right.left) OR Overlap(left, right.right) + ELSE + WHILE right.class = Nmop DO right := right.left END; + IF right.class = Nderef THEN right := right.left END; + IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END; + LOOP + IF left.class = Nvarpar THEN + WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO + right := right.left + END; + RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev) + ELSIF right.class = Nvarpar THEN + WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END; + RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev) + ELSIF (left.class = Nvar) & (right.class = Nvar) THEN + RETURN left.obj = right.obj + ELSIF (left.class = Nderef) & (right.class = Nderef) THEN + RETURN TRUE + ELSIF (left.class = Nindex) & (right.class = Nindex) THEN + IF (left.right.class = Nconst) & (right.right.class = Nconst) + & (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END; + left := left.left; right := right.left + ELSIF (left.class = Nfield) & (right.class = Nfield) THEN + IF left.obj # right.obj THEN RETURN FALSE END; + left := left.left; right := right.left; + WHILE left.class = Nguard DO left := left.left END; + WHILE right.class = Nguard DO right := right.left END + ELSE + RETURN FALSE + END + END + END + END Overlap; + + PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER); + VAR x: INTEGER; + BEGIN + IF n.class = Nconst THEN + length := n.conval.intval2 - 1 + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetStaticLength(n.left, length); GetStaticLength(n.right, x); + IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := n.typ.n - 1 + ELSIF n.typ.comp = DynArr THEN + length := -1 + ELSE (* error case *) + length := 4 + END + END + END GetStaticLength; + + PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node); + VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object; + BEGIN + IF n.class = Nconst THEN + length := NewIntConst(n.conval.intval2 - 1) + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x); + IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x) + ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus + END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := NewIntConst(n.typ.n - 1) + ELSIF n.typ.comp = DynArr THEN + d := 0; + WHILE n.class = Nindex DO n := n.left; INC(d) END; + ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar)); + IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN + GetTempVar("@tmp", n.left.typ, obj); + x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x); + n.left := NewLeaf(obj); (* tree is manipulated here *) + n := NewLeaf(obj); DeRef(n) + END; + IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN + StrDeref(n); + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus + ELSE + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + END; + length := n + ELSE (* error case *) + length := NewIntConst(4) + END + END + END GetMaxLength; + + PROCEDURE CheckBuffering* ( + VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node + ); + VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER; + BEGIN + IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) + & ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right)) + OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL) + OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN + IF (par # NIL) & (par.typ.comp = Array) THEN + len := par.typ.n - 1 + ELSE + IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END; + GetStaticLength(n, xlen); + IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END + END; + IF len # -1 THEN + typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp; + GetTempVar("@str", typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + ELSE + IF left # NIL THEN GetMaxLength(left, stat, last, length) + ELSE GetMaxLength(n, stat, last, length) + END; + typ := DevCPT.NewStr(Pointer, Basic); + typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp; + GetTempVar("@ptr", typ, obj); + x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x); + x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj); DeRef(n) + END; + StrDeref(n) + ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL) + & ((par # NIL) OR (n.class = Ncall)) + & ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN + GetTempVar("@cip", DevCPT.punktyp, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckBuffering; + + PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node); + VAR x: DevCPT.Node; obj: DevCPT.Object; + BEGIN + IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN + GetTempVar("@ptr", n.typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckVarParBuffering; + + + (* case optimization *) + + PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node); + VAR a: INTEGER; + BEGIN + IF n.left # NIL THEN + a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head); + IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END + ELSIF n.conval.intval < min THEN + min := n.conval.intval + END; + IF n.right # NIL THEN + a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head); + IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END + ELSIF n.conval.intval2 > max THEN + max := n.conval.intval2 + END; + INC(num); + IF n.conval.intval < n.conval.intval2 THEN + INC(num); + IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END + END + END Evaluate; + + PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node); + VAR n: DevCPT.Node; + BEGIN + IF root # head THEN + IF head.conval.intval2 < root.conval.intval THEN + Rebuild(root.left, head); + root.left := head.right; head.right := root; root := head + ELSE + Rebuild(root.right, head); + root.right := head.left; head.left := root; root := head + END + END + END Rebuild; + + PROCEDURE OptimizeCase* (VAR n: DevCPT.Node); + VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node; + BEGIN + IF n # NIL THEN + min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n; + Evaluate(n, min, max, num, dist, head); + limit := 6 * num; + IF limit < 100 THEN limit := 100 END; + IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN + INCL(n.conval.setval, useTable) + ELSE + IF num > 4 THEN Rebuild(n, head) END; + INCL(n.conval.setval, useTree); + OptimizeCase(n.left); + OptimizeCase(n.right) + END + END + END OptimizeCase; +(* + PROCEDURE ShowTree (n: DevCPT.Node; opts: SET); + BEGIN + IF n # NIL THEN + IF opts = {} THEN opts := n.conval.setval END; + IF useTable IN opts THEN + IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END; + DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END + ELSIF useTree IN opts THEN + DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")") + ELSE + ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW(" "); ShowTree(n.right, opts) + END + END + END ShowTree; +*) +BEGIN + zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0; + one := DevCPT.NewConst(); one.intval := 1; one.realval := 0; + two := DevCPT.NewConst(); two.intval := 2; two.realval := 0; + dummy := DevCPT.NewConst(); + quot := DevCPT.NewConst() +END Dev0CPB. diff --git a/Trurl-based/Dev0/Mod/CPC486.odc b/Trurl-based/Dev0/Mod/CPC486.odc new file mode 100644 index 0000000..4c05887 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPC486.odc differ diff --git a/Trurl-based/Dev0/Mod/CPC486.txt b/Trurl-based/Dev0/Mod/CPC486.txt new file mode 100644 index 0000000..5200c4b --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPC486.txt @@ -0,0 +1,2347 @@ +MODULE Dev0CPC486; + + (* THIS IS TEXT COPY OF CPC486.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPE := Dev0CPE, + DevCPL486 := Dev0CPL486; + + CONST + initializeAll = FALSE; (* initialize all local variable to zero *) + initializeOut = FALSE; (* initialize all OUT parameters to zero *) + initializeDyn = FALSE; (* initialize all open array OUT parameters to zero *) + initializeStr = FALSE; (* initialize rest of string value parameters to zero *) + + FpuControlRegister = 33EH; (* value for fpu control register initialization *) + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + VString16to8 = 29; VString8 = 30; VString16 = 31; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + getrfn = 26; putrfn = 27; + min = 34; max = 35; typ = 36; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + false = 0; true = 1; nil = 0; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI}; + + (* GenShiftOp *) + ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H; + + (* GenBitOp *) + BT = 20H; BTS = 28H; BTR = 30H; + + (* GenFDOp *) + FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H; + + (* GenFMOp *) + FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H; + + (* GenCode *) + SAHF = 9EH; WAIT = 9BH; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* sysflag *) + untagged = 1; callback = 2; noAlign = 3; union = 7; + interface = 10; ccall = -10; guarded = 10; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* pointer init limits *) + MaxPtrs = 10; MaxPush = 4; + + Tag0Offset = 12; + Mth0Offset = -4; + ArrDOffs = 8; + numPreIntProc = 2; + + stackAllocLimit = 2048; + + + VAR + imLevel*: ARRAY 64 OF BYTE; + intHandler*: DevCPT.Object; + inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN; + WReg, BReg, AllReg: SET; FReg: INTEGER; + ptrTab: ARRAY MaxPtrs OF INTEGER; + stkAllocLbl: DevCPL486.Label; + procedureUsesFpu: BOOLEAN; + + + PROCEDURE Init* (opt: SET); + CONST chk = 0; achk = 1; hint = 29; + BEGIN + inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt; + hints := hint IN opt; + stkAllocLbl := DevCPL486.NewLbl + END Init; + + PROCEDURE Reversed (cond: BYTE): BYTE; (* reversed condition *) + BEGIN + IF cond = lss THEN RETURN gtr + ELSIF cond = gtr THEN RETURN lss + ELSIF cond = leq THEN RETURN geq + ELSIF cond = geq THEN RETURN leq + ELSE RETURN cond + END + END Reversed; + + PROCEDURE Inverted (cc: INTEGER): INTEGER; (* inverted sense of condition code *) + BEGIN + IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END + END Inverted; + + PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN); + BEGIN + IF reversed THEN rel := Reversed(rel) END; + CASE rel OF + false: x.offset := ccNever + | true: x.offset := ccAlways + | eql: x.offset := ccE + | neq: x.offset := ccNE + | lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END + | leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END + | gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END + | geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END + END; + x.mode := Cond; x.form := Bool; x.reg := 0; + IF reversed THEN x.reg := 1 END; + IF signed THEN INC(x.reg, 2) END + END setCC; + + PROCEDURE StackAlloc*; (* pre: len = CX bytes; post: len = CX words *) + BEGIN + DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE) + END StackAlloc; + + PROCEDURE^ CheckAv* (reg: INTEGER); + + PROCEDURE AdjustStack (val: INTEGER); + VAR c, sp: DevCPL486.Item; + BEGIN + IF val < -stackAllocLimit THEN + CheckAv(CX); + DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp); + StackAlloc + ELSIF val # 0 THEN + DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE) + END + END AdjustStack; + + PROCEDURE DecStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END + END DecStack; + + PROCEDURE IncStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END + END IncStack; + + (*-----------------register handling------------------*) + + PROCEDURE SetReg* (reg: SET); + BEGIN + AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8 + END SetReg; + + PROCEDURE CheckReg*; + VAR reg: SET; + BEGIN + reg := AllReg - WReg; + IF reg # {} THEN + DevCPM.err(-777); (* register not released *) + IF AX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " AX" END; + IF BX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" BX" END; + IF CX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " CX" END; + IF DX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" DX" END; + IF SI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " SI" END; + IF DI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " DI" END; + WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4) + END; + IF FReg < 8 THEN DevCPM.err(-778); FReg := 8 (* float register not released *) + ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8 + END + END CheckReg; + + PROCEDURE CheckAv* (reg: INTEGER); + BEGIN + ASSERT(reg IN WReg) + END CheckAv; + + PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR n: INTEGER; s, s1: SET; + BEGIN + CASE f OF + | Byte, Bool, Char8, Int8: + s := BReg * {0..3} - stop; + IF (high IN stop) OR (high IN hint) & (s - hint # {}) THEN n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + IF s - hint # {} THEN s := s - hint END; + WHILE ~(n IN s) DO INC(n) END + ELSE + s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4); + IF s1 # {} THEN s := s1 END; + WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END; + IF ~(n IN s) THEN n := n + 4 END + END; + EXCL(BReg, n); EXCL(WReg, n MOD 4) + | Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: + s := WReg - stop; + IF high IN stop THEN s := s * {0..3} END; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END; + s1 := s - hint; + IF high IN hint THEN s1 := s1 * {0..3} END; + IF s1 # {} THEN s := s1 END; + IF 0 IN s THEN n := 0 + ELSIF 2 IN s THEN n := 2 + ELSIF 6 IN s THEN n := 6 + ELSIF 7 IN s THEN n := 7 + ELSIF 1 IN s THEN n := 1 + ELSE n := 3 + END; + EXCL(WReg, n); + IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END + | Real32, Real64: + IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END; + DEC(FReg); n := 0 + END; + DevCPL486.MakeReg(x, n, f); + END GetReg; + + PROCEDURE FreeReg (n, f: INTEGER); + BEGIN + IF f <= Int8 THEN + INCL(BReg, n); + IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END + ELSIF f IN realSet THEN + INC(FReg) + ELSIF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeReg; + + PROCEDURE FreeWReg (n: INTEGER); + BEGIN + IF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeWReg; + + PROCEDURE Free* (VAR x: DevCPL486.Item); + BEGIN + CASE x.mode OF + | Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END + | Ind: FreeWReg(x.reg); + IF x.scale # 0 THEN FreeWReg(x.index) END + | Reg: FreeReg(x.reg, x.form); + IF x.form = Int64 THEN FreeWReg(x.index) END + ELSE + END + END Free; + + PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *) + BEGIN + IF x.mode = Reg THEN + IF x.form = Int64 THEN FreeWReg(x.index) + ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4) + END + END + END FreeHi; + + PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *) + BEGIN + IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END; + IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop)) + ELSIF x.form IN realSet THEN RETURN ~(float IN stop) + ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop) + ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop)) + END + END Fits; + + PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR rh: DevCPL486.Item; + BEGIN + IF f = Int64 THEN + GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r); + GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh); + r.form := Int64; r.index := rh.reg + ELSE + IF f < Int16 THEN INCL(stop, high) END; + GetReg(r, f, hint, stop); DevCPL486.GenPop(r) + END + END Pop; + + PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *) + VAR r: DevCPL486.Item; f: BYTE; + BEGIN + f := x.typ.form; + IF x.mode = Con THEN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END; + IF con IN stop THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + ELSIF x.mode = Stk THEN + IF f IN realSet THEN + GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form) + ELSE + Pop(r, f, hint, stop) + END; + x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f + ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN + Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := Int32 + ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + Free(x); GetReg(r, f, hint, stop); + IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + END Load; + + PROCEDURE Push* (VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; + BEGIN + IF x.form IN realSet THEN + Load(x, {}, {}); DecStack(x.form); + Free(x); x.mode := Stk; + IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END; + DevCPL486.GenFStore(x, TRUE) + ELSIF x.form = Int64 THEN + Free(x); x.form := Int32; y := x; + IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END; + DevCPL486.GenPush(y); DevCPL486.GenPush(x); + x.mode := Stk; x.form := Int64 + ELSE + IF x.form < Int16 THEN Load(x, {}, {high}) + ELSIF x.form = Int16 THEN Load(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x); x.mode := Stk + END + END Push; + + PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN + IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x) + ELSE Load(x, hint, stop); + END + ELSE + CASE x.mode OF + | Var, VarPar: IF ~(mem IN stop) THEN RETURN END + | Con: IF ~(con IN stop) THEN RETURN END + | Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Stk: IF ~(stk IN stop) THEN RETURN END + | Reg: IF Fits(x, stop) THEN RETURN END + ELSE RETURN + END; + IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x) + ELSE Load(x, hint, stop) + END + END + END Assert; + + (*------------------------------------------------*) + + PROCEDURE LoadR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN + Free(x); DevCPL486.GenFLoad(x); + IF x.mode = Stk THEN IncStack(x.form) END; + GetReg(x, Real32, {}, {}) + END + END LoadR; + + PROCEDURE PushR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN LoadR(x) END; + DecStack(x.form); + Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE) + END PushR; + + PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSE + Free(x); GetReg(r, x.form, hint, stop); + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg + END + END LoadW; + + PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop); + IF (x.form < Int32) OR (x.form = Char16) THEN + r := x; x.form := Int32; DevCPL486.GenExtMove(r, x) + END + ELSE + Free(x); + IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END; + IF x.mode = Con THEN x.form := r.form END; + IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := r.form + END + END LoadL; + + PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r, rh, c: DevCPL486.Item; offs: INTEGER; + BEGIN + IF x.form = Int64 THEN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSIF x.mode = Reg THEN + FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop); + FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop); + x.form := Int32; DevCPL486.GenMove(x, r); + x.reg := x.index; DevCPL486.GenMove(x, rh); + x.reg := r.reg; x.index := rh.reg + ELSE + GetReg(rh, Int32, hint, stop + {AX}); + Free(x); + GetReg(r, Int32, hint, stop); + x.form := Int32; offs := x.offset; + IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END; + DevCPL486.GenMove(x, rh); + x.offset := offs; + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.index := rh.reg + END + ELSE + LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh); + x.index := rh.reg + END; + x.form := Int64 + END LoadLong; + + (*------------------------------------------------*) + + PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET); + BEGIN + ASSERT(x.mode = Reg); + GetReg(y, x.form, hint, stop); + DevCPL486.GenMove(x, y) + END CopyReg; + + PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = DInd THEN + x.mode := Ind + ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN + x.mode := Reg + ELSE + Free(x); GetReg(r, Pointer, hint, stop); + IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := Pointer + END; + x.form := Pointer; x.typ := DevCPT.anyptrtyp; + Assert(x, hint, stop) + END GetAdr; + + PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN); + VAR r, v: DevCPL486.Item; + BEGIN + IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer + ELSIF niltest THEN + GetAdr(x, {}, {mem, stk}); + DevCPL486.MakeReg(r, AX, Int32); + v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg; + DevCPL486.GenTest(r, v) + ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer + ELSE GetAdr(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x) + END PushAdr; + + PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET); + VAR n: BYTE; + BEGIN + a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ; + IF lev = DevCPL486.level THEN a.reg := BP + ELSE + a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev])); + WHILE n > 0 DO + a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n) + END + END + END LevelBase; + + PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *) + BEGIN + IF x.tmode = VarPar THEN + LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr; + ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind)); + len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32 + END; + INC(len.offset, typ.n * 4 + 4); + IF typ.sysflag = stackArray THEN len.offset := -4 END + END LenDesc; + + PROCEDURE Tag* (VAR x, tag: DevCPL486.Item); + VAR typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ) + ELSIF x.typ.form = Pointer THEN + ASSERT(x.mode = Reg); + tag.mode := Ind; tag.reg := x.reg; tag.offset := -4; + IF x.typ.sysflag = interface THEN tag.offset := 0 END + ELSIF x.tmode = VarPar THEN + LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4; + Free(tag) (* ??? *) + ELSIF x.tmode = Ind THEN + ASSERT(x.mode = Ind); + tag := x; tag.offset := -4 + ELSE + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ) + END; + tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp + END Tag; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN; + VAR fld: DevCPT.Object; + BEGIN + WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END; + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + REPEAT + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) + OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END; + fld := fld.link + END; + typ := typ.BaseTyp + UNTIL typ = NIL + END; + RETURN FALSE + END ContainsIPtrs; + + PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item); + VAR cv: DevCPT.Const; + BEGIN + IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END; + cv := DevCPT.NewConst(); + cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str; + DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp + END GuidFromString; + + PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END + END; + IF x.mode # Reg THEN + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + ELSE r := x + END; + IF nilTest THEN + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + DevCPL486.GenPush(r); p := r; + IF x.mode # Reg THEN Free(r) END; + GetReg(r, Pointer, {}, {}); + p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r); + p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPAddRef; + + PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END + END; + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + DevCPL486.MakeConst(c, 0, Pointer); + IF nilTest THEN + DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nilSet THEN DevCPL486.GenMove(c, p) END; + DevCPL486.GenPush(r); + p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r); + p.offset := 8; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPRelease; + + PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN + DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ; + WHILE typ.comp = DynArr DO (* complete dynamic array iterations *) + LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + END; + n := x.scale; i := 0; + WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END; + IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *) + DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n + END + END; + CASE x.mode OF + Var, VarPar: + lev := x.obj.mnolev; + IF lev <= 0 THEN + x.mode := Abs + ELSE + LevelBase(y, lev, hint, stop); + IF x.mode # VarPar THEN + x.mode := Ind + ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN + x.mode := DInd; x.offset := x.obj.adr + ELSE + y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind + END; + x.reg := y.reg + END; + x.form := x.typ.form + | LProc, XProc, IProc: + x.mode := Con; x.offset := 0; x.form := ProcTyp + | TProc, CProc: + x.form := ProcTyp + | Ind, Abs, Stk, Reg: + IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END + END + END Prepare; + + PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object); + BEGIN + INC(x.offset, field.adr); x.tmode := Con + END Field; + + PROCEDURE DeRef* (VAR x: DevCPL486.Item); + VAR btyp: DevCPT.Struct; + BEGIN + x.mode := Ind; x.tmode := Ind; x.scale := 0; + btyp := x.typ.BaseTyp; + IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0 + ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size + ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 + ELSE x.offset := 0 + END + END DeRef; + + PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *) + VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER; + BEGIN + btyp := x.typ.BaseTyp; elsize := btyp.size; + IF elsize = 0 THEN Free(y) + ELSIF x.typ.comp = Array THEN + len.mode := Con; len.obj := NIL; + IF y.mode = Con THEN + INC(x.offset, y.offset * elsize) + ELSE + Load(y, hint, stop + {mem, stk, short}); + IF inxchk THEN + DevCPL486.MakeConst(len, x.typ.n, Int32); + DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap) + END; + IF x.scale = 0 THEN x.index := y.reg + ELSE + IF x.scale MOD elsize # 0 THEN + IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4 + ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2 + ELSE elsize := 1 + END; + DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32); + DevCPL486.GenMul(len, y, FALSE) + END; + DevCPL486.MakeConst(len, x.scale DIV elsize, Int32); + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END; + x.scale := elsize + END; + x.tmode := Con + ELSE (* x.typ.comp = DynArr *) + IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END; + LenDesc(x, len, x.typ); + IF x.scale # 0 THEN + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE) + END; + IF (y.mode # Con) OR (y.offset # 0) THEN + IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN + Load(y, hint, stop + {mem, stk, con, short}) + ELSE y.form := Int32 + END; + IF inxchk & ~x.typ.untagged THEN + DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap) + END; + IF (y.mode = Con) & (btyp.comp # DynArr) THEN + INC(x.offset, y.offset * elsize) + ELSIF x.scale = 0 THEN + WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END; + x.index := y.reg; x.scale := btyp.size + ELSE + DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END + END; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END + END + END Index; + + PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN); + VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END; + IF ~guard & typ.untagged THEN DevCPM.err(139) + ELSIF ~guard OR typchk & ~typ.untagged THEN + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + IF (x.typ.form = Pointer) & (x.mode # Reg) THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag) + ELSE Tag(x, tag) + END; + IF ~guard THEN Free(x) END; + IF ~equal THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r); + tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev + END; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + IF guard THEN + IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END + ELSE setCC(x, eql, FALSE, FALSE) + END + END + END + END TypTest; + + PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct); + VAR tag, tdes: DevCPL486.Item; + BEGIN + (* tag must be in AX ! *) + IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END; + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + setCC(x, eql, FALSE, FALSE) + END + END ShortTypTest; + + PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER); + VAR c: DevCPL486.Item; + BEGIN + ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4)); + IF ranchk & (x.mode # Con) THEN + DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x); + IF min # 0 THEN + DevCPL486.GenAssert(ccLE, ranTrap); + c.offset := min; DevCPL486.GenComp(c, x); + DevCPL486.GenAssert(ccGE, ranTrap) + ELSIF max # 0 THEN + DevCPL486.GenAssert(ccBE, ranTrap) + ELSE + DevCPL486.GenAssert(ccNS, ranTrap) + END + END + END Check; + + PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN); + VAR c: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *) + END; + DevCPL486.GenFMOp(1FCH); (* FRNDINT *) + DevCPL486.GenFMOp(0D1H); (* FCOM *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.AllocConst(c, DevCPL486.one, Real32); + DevCPL486.GenFDOp(FSUB, c); + DevCPL486.SetLabel(local); + END Floor; + + PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + BEGIN + IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END; + DevCPL486.GenFStore(x, TRUE); + IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END + END Entier; + + PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *) + (* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *) + VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item; + BEGIN + f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk}); + IF y.form IN {Real32, Real64} THEN + IF f IN {Real32, Real64} THEN + IF m = Undef THEN + IF (y.form = Real64) & (f = Real32) THEN + IF y.mode # Reg THEN LoadR(y) END; + Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE) + END + ELSE + IF y.mode # Reg THEN LoadR(y) END; + IF m = Stk THEN DecStack(f) END; + IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END; + END + ELSE (* x not real *) + IF sysval THEN + IF y.mode = Reg THEN Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN + x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f + ELSE + ASSERT(y.form # Real64); + DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32; + IF m # Stk THEN + Pop(y, y.form, hint, stop); + IF f < Int16 THEN ASSERT(y.reg < 4) END; + y.form := f; + IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END + END + END + ELSE (* y.mode # Reg *) + y.form := f; + IF m # Undef THEN LoadW(y, hint, stop); Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END + END + END + ELSE (* not sysval *) + IF y.mode # Reg THEN LoadR(y) END; + Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN + Entier(x, y.typ, hint, stop); + ELSE + DecStack(f); y.mode := Stk; + IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END; + IF m = Stk THEN Entier(y, y.typ, {}, {}) + ELSIF m = Undef THEN Entier(y, y.typ, hint, stop) + ELSE Entier(y, y.typ, hint, stop + {stk}) + END; + IF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y) + END; + y.form := f; + IF (m # Undef) & (m # Stk) THEN + IF f = Int64 THEN + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + Free(y); DevCPL486.GenMove(y, x); + END + END + END + END + END + ELSE (* y not real *) + IF sysval THEN + IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END; + IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END + ELSE + CASE y.form OF + | Byte, Bool: + IF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char8: + IF f = Int8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, 0, 0) + ELSIF f = Char16 THEN (* ok *) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int32 THEN LoadL(y, hint, stop) + END + | Int8: + IF f = Char8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Int16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 0) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop) + END + | Int32, Set, Pointer, ProcTyp: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, -32768, 32767) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + END + | Int64: + IF f IN {Bool..Int32, Char16} THEN + (* make range checks !!! *) + FreeHi(y) + END + END + END; + IF f IN {Real32, Real64} THEN + IF sysval THEN + IF (m # Undef) & (m # Reg) THEN + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) + ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f + END + ELSE + IF y.mode = Reg THEN Push(y) END; + y.form := f; + IF m = Reg THEN LoadR(y) END + END + ELSE (* not sysval *) (* int -> float *) + IF y.mode = Reg THEN Push(y) END; + IF m = Stk THEN + Free(y); DevCPL486.GenFLoad(y); s := -4; + IF f = Real64 THEN DEC(s, 4) END; + IF y.mode = Stk THEN + IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END + END; + IF s # 0 THEN AdjustStack(s) END; + GetReg(y, Real32, {}, {}); + Free(y); DevCPL486.GenFStore(x, TRUE) + ELSIF m = Reg THEN + LoadR(y) + ELSIF m # Undef THEN + LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) + END + END + ELSE + y.form := f; + IF m = Stk THEN + IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END; + Push(y) + ELSIF m # Undef THEN + IF f = Int64 THEN + IF y.mode # Reg THEN LoadLong(y, hint, stop) END; + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); DevCPL486.GenMove(y, x) + END + END + END + END + END ConvMove; + + PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *) + VAR y: DevCPL486.Item; + BEGIN + ASSERT(x.mode # Con); + IF (size >= 0) + & ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4)) + OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END; +(* + IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form IN {Comp, Int64})) THEN DevCPM.err(220) END; +*) + y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop) + END Convert; + + PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET); + VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item; + BEGIN + IF mem IN stop THEN GetReg(x, Bool, hint, stop) END; + IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *) + DevCPL486.GenSetCC(y.offset, x) + ELSE + end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl; + DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *) + DevCPL486.SetLabel(F); + DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x); + DevCPL486.GenJump(ccAlways, end, TRUE); + DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); + DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x); + DevCPL486.SetLabel(end) + END; + IF x.mode # Reg THEN Free(x) END + END LoadCond; + + PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con)); + CASE subcl OF + | eql..geq: + DevCPL486.GenComp(y, x); Free(x); + setCC(x, subcl, rev, x.typ.form IN {Int8..Int32}) + | times: + IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END + | slash: + DevCPL486.GenXor(y, x) + | plus: + IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END + | minus, msk: + IF (x.form = Set) OR (subcl = msk) THEN (* and not *) + IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *) + ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *) + ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *) + ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *) + END + ELSE (* minus *) + IF rev THEN (* y - x *) + IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x) + ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *) + END + ELSE (* x - y *) + DevCPL486.GenSub(y, x, ovflchk) + END + END + | min, max: + local := DevCPL486.NewLbl; + DevCPL486.GenComp(y, x); + IF subcl = min THEN + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE) + ELSE DevCPL486.GenJump(ccLE, local, TRUE) + END + ELSE + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE) + ELSE DevCPL486.GenJump(ccGE, local, TRUE) + END + END; + DevCPL486.GenMove(y, x); + DevCPL486.SetLabel(local) + END; + Free(y); + IF x.mode # Reg THEN Free(x) END + END IntDOp; + + PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *) + BEGIN + ASSERT(x.form = Int64); + IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END; + Free(x); Free(y); x.form := Int32; y.form := Int32; + IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END; + INC(x.offset, 4); + IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END; + IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END; + END LargeInc; + + PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; a, b: DevCPL486.Item; + BEGIN + ASSERT(x.mode = Reg); + IF y.form = Int64 THEN LoadR(y) END; + IF y.mode = Reg THEN rev := ~rev END; + CASE subcl OF + | eql..geq: DevCPL486.GenFDOp(FCOMP, y) + | times: DevCPL486.GenFDOp(FMUL, y) + | slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END + | plus: DevCPL486.GenFDOp(FADD, y) + | minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END + | min, max: + IF y.mode = Reg THEN + DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *) + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END; + DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *) + ELSE + DevCPL486.GenFDOp(FCOM, y); + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END; + DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *) + DevCPL486.GenFLoad(y); + DevCPL486.SetLabel(local) + END + (* largeint support *) + | div: + IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END; + Floor(y, FALSE) + | mod: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1F8H); (* FPREM *) + DevCPL486.GenFMOp(1E4H); (* FTST *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX}); + DevCPL486.GenMove(a, b); + DevCPL486.GenFMOp(0D1H); (* FCOM *) + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenXor(b, a); Free(b); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.GenFMOp(0C1H); (* FADD ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + | ash: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1FDH); (* FSCALE *) + Floor(y, TRUE) + END; + IF y.mode = Stk THEN IncStack(y.form) END; + Free(y); + IF (subcl >= eql) & (subcl <= geq) THEN + Free(x); CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + setCC(x, subcl, rev, FALSE) + END + END FloatDOp; + + PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + VAR L: DevCPL486.Label; c: DevCPL486.Item; + BEGIN + CASE subcl OF + | minus: + IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END + | abs: + L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccNS, L, TRUE); + DevCPL486.GenNeg(x, ovflchk); + DevCPL486.SetLabel(L) + | cap: + DevCPL486.MakeConst(c, -1 - 20H, x.form); + DevCPL486.GenAnd(c, x) + | not: + DevCPL486.MakeConst(c, 1, x.form); + DevCPL486.GenXor(c, x) + END; + IF x.mode # Reg THEN Free(x) END + END IntMOp; + + PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + BEGIN + ASSERT(x.mode = Reg); + IF subcl = minus THEN DevCPL486.GenFMOp(FCHS) + ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS) + END + END FloatMOp; + + PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET); + (* range neg result + F F {x} + F T -{x} + T F {x..31} + T T -{0..x} *) + VAR c, r: DevCPL486.Item; val: INTEGER; + BEGIN + IF x.mode = Con THEN + IF range THEN + IF neg THEN val := -2 ELSE val := -1 END; + x.offset := SYSTEM.LSH(val, x.offset) + ELSE + val := 1; x.offset := SYSTEM.LSH(val, x.offset); + IF neg THEN x.offset := -1 - x.offset END + END + ELSE + Check(x, 0, 31); + IF neg THEN val := -2 + ELSIF range THEN val := -1 + ELSE val := 1 + END; + DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r); + IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END; + Free(x); x.reg := r.reg + END; + x.typ := DevCPT.settyp; x.form := Set + END MakeSet; + + PROCEDURE MakeCond* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Con THEN + setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE) + ELSE + DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); Free(x); + setCC(x, neq, FALSE, FALSE) + END + END MakeCond; + + PROCEDURE Not* (VAR x: DevCPL486.Item); + VAR a: INTEGER; + BEGIN + x.offset := Inverted(x.offset); (* invert cc *) + END Not; + + PROCEDURE Odd* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END; + Free(x); DevCPL486.MakeConst(c, 1, x.form); + IF x.mode = Reg THEN + IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END; + DevCPL486.GenAnd(c, x) + ELSE + c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x) + END; + setCC(x, neq, FALSE, FALSE) + END Odd; + + PROCEDURE In* (VAR x, y: DevCPL486.Item); + BEGIN + IF y.form = Set THEN Check(x, 0, 31) END; + DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y); + setCC(x, lss, FALSE, FALSE); (* carry set *) + END In; + + PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *) + VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER; + BEGIN + IF subcl = ash THEN opl := SHL; opr := SAR + ELSIF subcl = lsh THEN opl := SHL; opr := SHR + ELSE opl := ROL; opr := ROR + END; + IF y.mode = Con THEN + IF y.offset > 0 THEN + DevCPL486.GenShiftOp(opl, y, x) + ELSIF y.offset < 0 THEN + y.offset := -y.offset; + DevCPL486.GenShiftOp(opr, y, x) + END + ELSE + ASSERT(y.mode = Reg); + Check(y, -31, 31); + L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; + DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y); + DevCPL486.GenJump(ccNS, L1, TRUE); + DevCPL486.GenNeg(y, FALSE); + DevCPL486.GenShiftOp(opr, y, x); + DevCPL486.GenJump(ccAlways, L2, TRUE); + DevCPL486.SetLabel(L1); + DevCPL486.GenShiftOp(opl, y, x); + DevCPL486.SetLabel(L2); + Free(y) + END; + IF x.mode # Reg THEN Free(x) END + END Shift; + + PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN); + VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN; + BEGIN + ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE; + IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END; + DevCPL486.GenDiv(y, mod, pos); Free(y); + IF mod THEN + r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *) + END + END DivMod; + + PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *) + BEGIN + IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset) + ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset + END; + x.scale := 0; x.typ := typ; x.form := typ.form + END Mem; + + PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *) + BEGIN + IF len.mode = Con THEN + IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END + ELSE + Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len) + END; + FreeWReg(SI); FreeWReg(DI) + END SysMove; + + PROCEDURE Len* (VAR x, y: DevCPL486.Item); + VAR typ: DevCPT.Struct; dim: INTEGER; + BEGIN + dim := y.offset; typ := x.typ; + IF typ.untagged THEN DevCPM.err(136) END; + WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END; + LenDesc(x, x, typ); + END Len; + + PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER; + BEGIN + CASE x.form OF + | String8, VString8: RETURN 1 + | String16, VString16: RETURN 2 + | VString16to8: RETURN 0 + | Comp: RETURN x.typ.BaseTyp.size + END + END StringWSize; + + PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN); + VAR sw, dw: INTEGER; + BEGIN + CheckAv(CX); + IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN + DevCPL486.GenBlockComp(4, 4) + ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index) + ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index) + ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index) + ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index) + ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x)) + END; + FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE); + END CmpString; + + PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item); + VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct; + BEGIN + atyp := y.typ; + WHILE ftyp.comp = DynArr DO + IF ftyp.BaseTyp = DevCPT.bytetyp THEN + IF atyp.comp = DynArr THEN + IF atyp.untagged THEN DevCPM.err(137) END; + LenDesc(y, len, atyp); + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z); + len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp; + WHILE atyp.comp = DynArr DO + LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE); + IF y.tmode = VarPar THEN Free(z) END; (* ??? *) + atyp := atyp.BaseTyp + END; + DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE); + Free(len) + ELSE + DevCPL486.MakeConst(len, atyp.size, Int32) + END + ELSE + IF atyp.comp = DynArr THEN LenDesc(y, len, atyp); + IF atyp.untagged THEN DevCPM.err(137) END; + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + ELSE DevCPL486.MakeConst(len, atyp.n, Int32) + END + END; + DevCPL486.GenPush(len); + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END + END VarParDynArr; + + PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *) + BEGIN + IF y.mode = Con THEN + IF y.form IN {Real32, Real64} THEN + DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {}); + IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *) + ELSIF x.form = Int64 THEN + ASSERT(x.mode IN {Ind, Abs}); + y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x); + y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x); + DEC(x.offset, 4); x.form := Int64 + ELSE + DevCPL486.GenMove(y, x) + END + ELSE + IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(x.form = Pointer); + GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer + END; + IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END; + ConvMove(x, y, FALSE, {}, {}) + END; + Free(x) + END Assign; + + PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET); + VAR c: DevCPL486.Item; + BEGIN + IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSE len.mode := Con + END; + len.typ := DevCPT.int32typ + END ArrayLen; + +(* + src dest zero +sx = sy x b y b +SHORT(lx) = sy x b+ x w y b +SHORT(lx) = SHORT(ly) x b+ x w y b+ + +lx = ly x w y w +LONG(sx) = ly x b y w * +LONG(SHORT(lx)) = ly x b+ x w* y w * + +sx := sy y b x b +sx := SHORT(ly) y b+ y w x b + +lx := ly y w x w +lx := LONG(sy) y b x w * +lx := LONG(SHORT(ly)) y b+ y w* x w * +*) + + PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *) + BEGIN + IF (x.typ.comp = DynArr) & x.typ.untagged THEN + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1) + ELSE + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0) + END; + FreeWReg(SI); FreeWReg(DI) + END AddCopy; + + PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *) + VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item; + BEGIN + sx := x.typ.size; CheckAv(CX); + IF y.form IN {String8, String16} THEN + sy := y.index * y.typ.BaseTyp.size; + IF x.typ.comp = Array THEN (* adjust size for optimal performance *) + sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4; + IF sy4 <= sx THEN sy := sy4 + ELSIF sy2 <= sx THEN sy := sy2 + ELSIF sy > sx THEN DevCPM.err(114); sy := 1 + END + ELSIF inxchk & ~x.typ.untagged THEN (* check array length *) + Free(x); LenDesc(x, c, x.typ); + DevCPL486.MakeConst(y, y.index, Int32); + DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap); + Free(c) + END; + DevCPL486.GenBlockMove(1, sy) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1) + ELSE + Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c); + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0) + END + ELSIF y.form IN {VString16to8, VString8, VString16} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + ASSERT(y.mode # Stk) + ELSIF short THEN (* COPY *) + sy := y.typ.size; + IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END; + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + IF y.mode = Stk THEN AdjustStack(sy) END + ELSE (* := *) + IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END; + IF y.mode = Stk THEN AdjustStack(sy) END + END; + FreeWReg(SI); FreeWReg(DI) + END Copy; + + PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + CheckAv(AX); CheckAv(CX); + DevCPL486.GenStringLength(typ.BaseTyp.size, -1); + Free(x); GetReg(x, Int32, {}, wreg - {CX}); + DevCPL486.GenNot(x); + IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END; + FreeWReg(DI) + END StrLen; + + PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *) + VAR c: DevCPL486.Item; + BEGIN + IF y.mode = Con THEN fact := fact * y.offset + ELSE + IF ranchk OR inxchk THEN + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap) + END; + DevCPL486.GenPush(y); + IF z.mode = Con THEN z := y + ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y) + END + END + END MulDim; + + PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *) + (* y const or on stack *) + VAR z: DevCPL486.Item; end: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) & (x.form = Pointer)); + z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32; + IF y.mode = Con THEN y.form := Int32 + ELSE Pop(y, Int32, {}, {}) + END; + end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *) + DevCPL486.GenMove(y, z); + DevCPL486.SetLabel(end); + IF y.mode = Reg THEN Free(y) END + END SetDim; + + PROCEDURE SysNew* (VAR x: DevCPL486.Item); + BEGIN + DevCPM.err(141) + END SysNew; + + PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER); + (* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *) + VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label; + BEGIN + typ := x.typ.BaseTyp; + IF typ.untagged THEN DevCPM.err(138) END; + IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ); + IF ContainsIPtrs(typ) THEN INC(tag.offset) END; + DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewRec; + ELSE eltyp := typ.BaseTyp; + IF typ.comp = Array THEN + nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n + ELSE (* DynArr *) + nofdim := typ.n+1; + WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END + END ; + WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END; + IF eltyp.comp = Record THEN + IF eltyp.untagged THEN DevCPM.err(138) END; + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp); + IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END; + ELSIF eltyp.form = Pointer THEN + IF ~eltyp.untagged THEN + DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *) + ELSIF eltyp.sysflag = interface THEN + DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *) + ELSE + DevCPL486.MakeConst(tag, 12, Pointer) + END + ELSE (* eltyp is pointerless basic type *) + CASE eltyp.form OF + | Undef, Byte, Char8: n := 1; + | Int16: n := 2; + | Int8: n := 3; + | Int32: n := 4; + | Bool: n := 5; + | Set: n := 6; + | Real32: n := 7; + | Real64: n := 8; + | Char16: n := 9; + | Int64: n := 10; + | ProcTyp: n := 11; + END; + DevCPL486.MakeConst(tag, n, Pointer) +(* + DevCPL486.MakeConst(tag, eltyp.size, Pointer) +*) + END; + IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL + ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk) + END; + DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p); + DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewArr; + END; + DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX}); + IF typ.comp = DynArr THEN (* set flags for nil test *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x) + ELSIF typ.comp = Record THEN + n := NumOfIntProc(typ); + IF n > 0 THEN (* interface method table pointer setup *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE); + tag.offset := - 4 * (n + numPreIntProc); + p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer; + DevCPL486.GenMove(tag, p); + IF nofel.mode # Con THEN (* unk pointer setup *) + p.offset := 8; + DevCPL486.GenMove(nofel, p); + Free(nofel) + END; + DevCPL486.SetLabel(lbl); + END + END + END New; + + PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *) + VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct; + BEGIN + par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form; + IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END; + IF ap.typ = DevCPT.niltyp THEN + IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN + DevCPM.err(142) + END; + DevCPL486.GenPush(ap) + ELSIF par.typ.comp = DynArr THEN + IF ap.form IN {String8, String16} THEN + IF ~par.typ.untagged THEN + DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c) + END; + ap.mode := Con; DevCPL486.GenPush(ap); + ELSIF ap.form IN {VString8, VString16} THEN + DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a); + IF ~par.typ.untagged THEN + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c); + Free(ap); StrLen(c, ap.typ, TRUE); + DevCPL486.GenPush(c); Free(c) + END; + DevCPL486.GenPush(a) + ELSE + IF ~par.typ.untagged THEN + IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *) + VarParDynArr(par.typ, ap) + END; + PushAdr(ap, niltest) + END + ELSIF fp.mode = VarPar THEN + recTyp := ap.typ; + IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END; + IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN + Tag(ap, tag); + IF rec & (tag.mode # Con) THEN + GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c + END; + DevCPL486.GenPush(tag); + IF tag.mode # Con THEN niltest := FALSE END; + PushAdr(ap, niltest); + IF rec THEN Free(tag) END + ELSE PushAdr(ap, niltest) + END; + tag.typ := recTyp + ELSIF par.form = Comp THEN + s := par.typ.size; + IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN + s := (s + 3) DIV 4 * 4; AdjustStack(-s); + IF ap.form IN {String8, String16} THEN + IF ap.index > 1 THEN (* nonempty string *) + ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4; + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenBlockMove(1, ss); + ELSE + ss := 0; + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c) + END; + IF s > ss THEN + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(1, s - ss) + END; + ELSE + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n); + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(StringWSize(par), 0) + END + ELSE + IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *) + AdjustStack((4 - s) DIV 4 * 4); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c) + ELSE + AdjustStack((-s) DIV 4 * 4); + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + IF ap.form IN {String8, String16} THEN + DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4) + ELSIF ap.form IN {VString8, VString16, VString16to8} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n) + ELSE + DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4) + END + END + END + ELSIF ap.mode = Con THEN + IF ap.form IN {Real32, Real64} THEN (* ??? push const *) + DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE) + ELSE + ap.form := Int32; + IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END; + DevCPL486.GenPush(ap) + END + ELSIF ap.typ.form = Pointer THEN + recTyp := ap.typ.BaseTyp; + IF rec THEN + Load(ap, {}, {}); Tag(ap, tag); + IF tag.mode = Con THEN (* explicit nil test needed *) + DevCPL486.MakeReg(a, AX, Int32); + c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg; + DevCPL486.GenTest(a, c) + END + END; + DevCPL486.GenPush(ap); Free(ap); + tag.typ := recTyp + ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(par.form = Pointer); + PushAdr(ap, FALSE) + ELSE + ConvMove(par, ap, FALSE, {}, {high}); + END + END Param; + + PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item); + VAR r: DevCPL486.Item; + BEGIN + DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *) + IF res.mode = Con THEN + IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res); + ELSIF r.form = Int64 THEN + r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r); + r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r) + ELSE DevCPL486.GenMove(res, r); + END + ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(r.form = Pointer); + GetAdr(res, {}, wreg - {AX}) + ELSE + r.index := DX; (* for int64 *) + ConvMove(r, res, FALSE, wreg - {AX} + {high}, {}); + END; + Free(res) + END Result; + + PROCEDURE InitFpu; + VAR x: DevCPL486.Item; + BEGIN + DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x); + DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *) + DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *) + END InitFpu; + + PROCEDURE PrepCall* (proc: DevCPT.Object); + VAR lev: BYTE; r: DevCPL486.Item; + BEGIN + lev := proc.mnolev; + IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r) + END + END PrepCall; + + PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *) + VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object; + BEGIN + IF x.mode IN {LProc, XProc, IProc} THEN + lev := x.obj.mnolev; saved := FALSE; + IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *) + n := imLevel[DevCPL486.level] - imLevel[lev]; + IF n > 0 THEN + saved := TRUE; + y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4; + DevCPL486.MakeReg(r, BX, Pointer); + WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END + END + END; + DevCPL486.GenCall(x); + IF x.obj.sysflag = ccall THEN (* remove parameters *) + p := x.obj.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + IF saved THEN DevCPL486.GenPop(r) END; + ELSIF x.mode = TProc THEN + IF x.scale = 1 THEN (* super *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp) + ELSIF x.scale = 2 THEN (* static call *) + DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + tag.obj := DevCPE.TypeObj(typ) + ELSIF x.scale = 3 THEN (* interface method call *) + DevCPM.err(200) + END; + IF tag.mode = Con THEN + y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0 + ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *) + y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0; + IF tag.mode = Ind THEN (* nil test *) + DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag) + END + ELSE + IF tag.mode = Reg THEN y.reg := tag.reg + ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y) + END; + y.mode := Ind; y.offset := 0; y.scale := 0 + END; + IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset + ELSIF tag.typ.untagged THEN DevCPM.err(140) + ELSE + IF x.obj.link.typ.sysflag = interface THEN (* correct method number *) + x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset + END; + INC(y.offset, Mth0Offset - 4 * x.offset) + END; + DevCPL486.GenCall(y); Free(y) + ELSIF x.mode = CProc THEN + IF x.obj.link # NIL THEN (* tag = first param *) + IF x.obj.link.mode = VarPar THEN + GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag) + ELSE + (* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *) + Result(x.obj.link, tag) (* use result load for first parameter *) + END + END; + i := 1; n := ORD(x.obj.conval.ext^[0]); + WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END + ELSE (* proc var *) + DevCPL486.GenCall(x); Free(x); + IF x.typ.sysflag = ccall THEN (* remove parameters *) + p := x.typ.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + x.typ := x.typ.BaseTyp + END; + IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128) + & ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *) + InitFpu + END; + CheckReg; + IF x.typ.form = Int64 THEN + GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX}); + x.index := y.reg; x.form := Int64 + ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high}) + END + END Call; + + PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *) + VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct; + BEGIN + IF typ.untagged THEN DevCPM.err(-137) END; + ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer; + DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32); + DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp + END; + ptr.offset := adr; DevCPL486.GenMove(ptr, src); + DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE); + (* CX = length in bytes *) + StackAlloc; + (* CX = length in 32bit words *) + DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr); + DevCPL486.GenBlockMove(4, 0) (* 32bit moves *) + END CopyDynArray; + + PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER); + VAR i, j, x: INTEGER; + BEGIN + (* align *) + i := 1; + WHILE i < n DO + x := tab[i]; j := i-1; + WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END; + tab[j+1] := x; INC(i) + END; + (* eliminate equals *) + i := 1; j := 1; + WHILE i < n DO + IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END; + INC(i) + END; + n := j + END Sort; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form IN {Pointer, ProcTyp} THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END; + INC(num); + IF adr MOD 4 # 0 THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END; + INC(num) + END + ELSIF typ.comp = Record THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.name^ = DevCPM.HdPtrName) OR + (fld.name^ = DevCPM.HdUtPtrName) OR + (fld.name^ = DevCPM.HdProcName) THEN + FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num) + ELSE FindPtrs(fld.typ, fld.adr + adr, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, num); + IF num # i THEN i := 1; + WHILE (i < n) & (num <= MaxPtrs) DO + INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i) + END + END + END + END + END FindPtrs; + + PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item); + VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr; + DevCPL486.MakeReg(y, DI, Int32); + IF par.typ.comp # DynArr THEN + DevCPL486.GenMove(x, y); + lbl := DevCPL486.NewLbl; + IF ODD(par.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zreg, y); + DevCPL486.GenJump(ccE, lbl, TRUE) + END; + size := par.typ.size; + IF size <= 16 THEN + x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0; + WHILE size > 0 DO + IF size = 1 THEN x.form := Int8; s := 1 + ELSIF size = 2 THEN x.form := Int16; s := 2 + ELSE x.form := Int32; s := 4 + END; + zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s) + END; + zreg.form := Int32 + ELSE + DevCPL486.GenBlockStore(1, size) + END; + DevCPL486.SetLabel(lbl) + ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *) + DevCPL486.GenMove(x, y); + DevCPL486.MakeReg(len, CX, Int32); + INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *) + bt := par.typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp + END; + size := bt.size; + IF size MOD 4 = 0 THEN size := size DIV 4; s := 4 + ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2 + ELSE s := 1 + END; + DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE); + DevCPL486.GenBlockStore(s, 0) + END + END InitOutPar; + + PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); + VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER; + BEGIN + op := 0; par := proc.link; + WHILE par # NIL DO (* count out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END; + par := par.link + END; + DevCPL486.MakeConst(zero, 0, Int32); + IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *) + WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END + ELSE + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); + IF size <= 32 THEN (* use PUSH reg *) + WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END + ELSE (* use string store *) + AdjustStack(-size); + DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + DevCPL486.GenBlockStore(1, size) + END; + IF op > 0 THEN + par := proc.link; + WHILE par # NIL DO (* init out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END; + par := par.link + END + END + END + END AllocAndInitAll; + + PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *) + VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + IF ptrinit & (proc.scope # NIL) THEN + nofptrs := 0; obj := proc.scope.scope; (* local variables *) + WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO + FindPtrs(obj.typ, obj.adr, nofptrs); + obj := obj.link + END; + IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN + base := proc.conval.intval2; + Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END; + INC(i) + END; + IF a # base THEN INC(gaps) END; + IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN + DevCPL486.MakeConst(z, 0, Pointer); + IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END; + i := 0; a := size + base; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END; + DevCPL486.GenPush(z); INC(i) + END; + IF a # base THEN AdjustStack(base - a) END + ELSE + AdjustStack(-size); + DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z); + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END + ELSE + AdjustStack(-size) + END + ELSE + nofptrs := 0; + AdjustStack(-size) + END + END AllocAndInitPtrs1; + + PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *) + VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label; + BEGIN + IF ptrinit THEN + zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer); + IF nofptrs > MaxPtrs THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y); + DevCPL486.GenStrStore(size) + END; + obj := proc.link; (* parameters *) + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN + IF ~zeroed THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE + END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + IF ODD(obj.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zero, y); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nofptrs > MaxPtrs THEN + DevCPL486.GenStrStore(obj.typ.size) + ELSE + Sort(ptrTab, nofptrs); + x.reg := DI; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END; + IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END + END + END; + obj := obj.link + END + END + END InitPtrs2; + + PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN; + VAR obj: DevCPT.Object; nofptrs: INTEGER; + BEGIN + IF ptrinit THEN + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN RETURN TRUE END + END; + obj := obj.link + END + END; + RETURN FALSE + END NeedOutPtrInit; + + PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN); + VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER; + BEGIN + procedureUsesFpu := useFpu; + SetReg({AX, CX, DX, SI, DI}); + DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer); + IF proc # NIL THEN (* enter proc *) + DevCPL486.SetLabel(proc.adr); + IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + adr := proc.conval.intval2; size := -adr; + IF isGuarded IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); + r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL; + DevCPL486.GenPush(r1); + intHandler.used := TRUE; + r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler; + DevCPL486.GenPush(r1); + r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenPush(r1); + DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1); + DEC(size, 24) + ELSE + IF imVar IN proc.conval.setval THEN (* set down pointer *) + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4) + END; + IF isCallback IN proc.conval.setval THEN + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8) + END + END; + ASSERT(size >= 0); + IF initializeAll THEN + AllocAndInitAll(proc, adr, size, np) + ELSE + AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *) + InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *) + END; + par := proc.link; (* parameters *) + WHILE par # NIL DO + IF (par.mode = Var) & (par.typ.comp = DynArr) THEN + CopyDynArray(par.adr, par.typ) + END; + par := par.link + END; + IF imVar IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r) + END + END + ELSIF ~empty THEN (* enter module *) + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r) + END; + IF useFpu THEN InitFpu END + END Enter; + + PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN); + VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER; + BEGIN + DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer); + IF proc # NIL THEN (* exit proc *) + IF proc.sysflag # noframe THEN + IF ~empty OR NeedOutPtrInit(proc) THEN + IF isGuarded IN proc.conval.setval THEN (* remove exception frame *) + x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32; + DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r); + x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x); + size := 12 + ELSE + size := 0; + IF imVar IN proc.conval.setval THEN INC(size, 4) END; + IF isCallback IN proc.conval.setval THEN INC(size, 8) END + END; + IF size > 0 THEN + x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32; + DevCPL486.GenLoadAdr(x, sp); + IF size > 4 THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r) + END; + IF size # 8 THEN + DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r) + END + ELSE + DevCPL486.GenMove(fp, sp) + END; + DevCPL486.GenPop(fp) + END; + IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0) + ELSE DevCPL486.GenReturn(proc.conval.intval - 8) + END + END + ELSE (* exit module *) + IF ~empty THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r); + DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp) + END; + DevCPL486.GenReturn(0) + END + END Exit; + + PROCEDURE InstallStackAlloc*; + VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label; + BEGIN + IF stkAllocLbl # DevCPL486.NewLbl THEN + DevCPL486.SetLabel(stkAllocLbl); + DevCPL486.MakeReg(ax, AX, Int32); + DevCPL486.MakeReg(cx, CX, Int32); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.GenPush(ax); + DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE); + l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx); + DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax); + DevCPL486.GenSub(ax, sp, FALSE); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax); + l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE); + l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c); + DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE); + DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE); + DevCPL486.GenJump(ccNE, l1, TRUE); + DevCPL486.SetLabel(l2); + DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE); + x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1; + DevCPL486.GenMove(x, ax); + DevCPL486.GenPush(ax); + DevCPL486.GenMove(x, ax); + DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx); + DevCPL486.GenReturn(0); + name := "$StackAlloc"; DevCPE.OutRefName(name); + END + END InstallStackAlloc; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + DevCPL486.GenAssert(ccNever, n) + END Trap; + + PROCEDURE Jump* (VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(ccAlways, L, FALSE) + END Jump; + + PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(x.offset, L, FALSE); + END JumpT; + + PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(Inverted(x.offset), L, FALSE); + END JumpF; + + PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label); + VAR c: DevCPL486.Item; n: INTEGER; + BEGIN + n := high - low + 1; + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE); + DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccAE, else, FALSE); + DevCPL486.GenCaseJump(x) + END CaseTableJump; + + PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + IF high = low THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END; + DevCPL486.GenJump(ccE, this, FALSE) + ELSIF first THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccL, else, FALSE); + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccLE, this, FALSE); + ELSE + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccG, else, FALSE); + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccGE, this, FALSE); + END + END CaseJump; + +BEGIN + imLevel[0] := 0 +END Dev0CPC486. diff --git a/Trurl-based/Dev0/Mod/CPE.odc b/Trurl-based/Dev0/Mod/CPE.odc new file mode 100644 index 0000000..3d1952b Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPE.odc differ diff --git a/Trurl-based/Dev0/Mod/CPE.txt b/Trurl-based/Dev0/Mod/CPE.txt new file mode 100644 index 0000000..798b19e --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPE.txt @@ -0,0 +1,1120 @@ +MODULE Dev0CPE; + + (* THIS IS TEXT COPY OF CPE.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems, Robert Campbell" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, (* Dates, *) DevCPM := Dev0CPM, DevCPT := Dev0CPT; + + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* object modes *) + Fld = 4; Typ = 5; Head = 12; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6; + mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13; + mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3; + mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; + mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13; + mInterface = 32; mGuid = 33; mResult = 34; + + (* sysflag *) + untagged = 1; noAlign = 3; union = 7; interface = 10; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* kernel flags *) + iptrs = 30; + + expAllFields = TRUE; + + (* implementation restrictions *) + CodeBlocks = 512; + CodeLength = 16384; + MaxNameTab = 800000H; + + useAllRef = FALSE; + outSignatures = TRUE; + + TYPE + CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR; + + VAR + pc*: INTEGER; + dsize*: INTEGER; (* global data size *) + KNewRec*, KNewArr*: DevCPT.Object; + closeLbl*: INTEGER; + CaseLinks*: DevCPT.LinkList; + + processor: INTEGER; + bigEndian: BOOLEAN; + procVarIndirect: BOOLEAN; + idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER; + Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object; + outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN; + codePos, srcPos: INTEGER; + options: SET; + code: ARRAY CodeBlocks OF CodeBlock; + actual: CodeBlock; + actIdx, blkIdx: INTEGER; + CodeOvF: BOOLEAN; + zero: ARRAY 16 OF SHORTCHAR; (* all 0X *) + imports: INTEGER; + dllList, dllLast: DevCPT.Object; + + + PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + CONST N = 4294967296.0; (* 2^32 *) + VAR rh, rl: REAL; + BEGIN + rl := con.intval; rh := con.realval / N; + IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N + ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N + END; + hi := SHORT(ENTIER(rh)); + rl := rl + (rh - hi) * N; + IF rl < 0 THEN hi := hi - 1; rl := rl + N + ELSIF rl >= N THEN hi := hi + 1; rl := rl - N + END; + IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END; + low := SHORT(ENTIER(rl)) +(* + hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0)); + r := con.realval + con.intval - hi * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + low := SHORT(ENTIER(r)) +*) + END GetLongWords; + + PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER); + VAR r: SHORTREAL; + BEGIN + r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r) + END GetRealWord; + + PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + TYPE A = ARRAY 2 OF INTEGER; + VAR a: A; + BEGIN + a := SYSTEM.VAL(A, con.realval); + IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END + END GetRealWords; + + PROCEDURE IsSame (x, y: REAL): BOOLEAN; + BEGIN + RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y)) + END IsSame; + + PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER); + VAR c: DevCPT.Const; + BEGIN + INCL(con.setval, form); + CASE form OF + | String8: + obj := Const8; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END + | String16: + obj := Const16; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END + | Int64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO + c := c.link + END; + IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END + | Real32: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 4) END + | Real64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx64; INC(idx64, 8) END + | Guid: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 16) END + END; + IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END; + con.intval := adr + END AllocConst; + + + PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *) + VAR obj: DevCPT.Object; name: DevCPT.Name; + BEGIN + IF typ.strobj = NIL THEN + name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *) + obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END + END AllocTypDesc; + + + PROCEDURE PutByte* (a, x: INTEGER); + BEGIN + code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256)) + END PutByte; + + PROCEDURE PutShort* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 256); PutByte(a + 1, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256) + END + END PutShort; + + PROCEDURE PutWord* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H); + PutByte(a + 2, x DIV 256); PutByte(a + 3, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256); + PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H) + END + END PutWord; + + PROCEDURE ThisByte* (a: INTEGER): INTEGER; + BEGIN + RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength]) + END ThisByte; + + PROCEDURE ThisShort* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ThisByte(a) * 256 + ThisByte(a+1) + ELSE + RETURN ThisByte(a+1) * 256 + ThisByte(a) + END + END ThisShort; + + PROCEDURE ThisWord* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3) + ELSE + RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a) + END + END ThisWord; + + PROCEDURE GenByte* (x: INTEGER); + BEGIN + IF actIdx >= CodeLength THEN + IF blkIdx < CodeBlocks THEN + NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0 + ELSE + IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END; + actIdx := 0; pc := 0 + END + END; + actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc) + END GenByte; + + PROCEDURE GenShort* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256) + END + END GenShort; + + PROCEDURE GenWord* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H) + END + END GenWord; + + PROCEDURE WriteCode; + VAR i, j, k, n: INTEGER; b: CodeBlock; + BEGIN + j := 0; k := 0; + WHILE j < pc DO + n := pc - j; i := 0; b := code[k]; + IF n > CodeLength THEN n := CodeLength END; + WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END; + INC(j, n); INC(k) + END + END WriteCode; + + + PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList; + VAR link: DevCPT.LinkList; m: DevCPT.Object; + BEGIN + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ)); + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp)); + IF obj.mnolev >= 0 THEN (* not imported *) + CASE obj.mode OF + | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END + | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END + | Var: offs := offs + dsize; obj := Data + | Con, IProc, XProc, LProc: + END + ELSIF obj.mode = Typ THEN + IF obj.typ.untagged THEN (* add desc for imported untagged types *) + IF obj.links = NIL THEN obj.link := descList; descList := obj END + ELSE + m := DevCPT.GlbMod[-obj.mnolev]; + IF m.library # NIL THEN RETURN NIL END (* type import from dll *) + END + END; + link := obj.links; + WHILE (link # NIL) & (link.offset # offs) DO link := link.next END; + IF link = NIL THEN + NEW(link); link.offset := offs; link.linkadr := 0; + link.next := obj.links; obj.links := link + END; + RETURN link + END OffsetLink; + + + PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + obj := typ.strobj; + IF obj = NIL THEN + obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0; + obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END; + RETURN obj + END TypeObj; + + + PROCEDURE Align (n: INTEGER); + VAR p: INTEGER; + BEGIN + p := DevCPM.ObjLen(); + DevCPM.ObjWBytes(zero, (-p) MOD n) + END Align; + + PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR); + VAR ch: SHORTCHAR; i: SHORTINT; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256))) + END + END Out2; + + PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H))); + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjWLInt(x) + END + END Out4; + + PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER); + VAR link: DevCPT.LinkList; + BEGIN + link := OffsetLink(obj, offs); + IF link # NIL THEN + Out4(typ * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := -(DevCPM.ObjLen() - headSize - 4) + ELSE Out4(0) + END + END OutReference; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form = Pointer THEN + IF ip & (typ.sysflag = interface) + OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface) + OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num) + ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, ip, num); + IF num # i THEN i := 1; + WHILE i < n DO + INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i) + END + END + END + END + END FindPtrs; + + + PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR); + BEGIN + DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name) + END OutRefName; + + PROCEDURE OutRefs* (obj: DevCPT.Object); + VAR f: BYTE; + BEGIN + IF outRef & (obj # NIL) THEN + OutRefs(obj.left); + IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN + f := obj.typ.form; + IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) + OR outURef & (obj.typ.comp # DynArr) + OR outAllRef & ~obj.typ.untagged + OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN + IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END; + IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr))) + ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec))) + ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16))) + ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64))) + ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid))) + ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult))) + ELSIF f = Pointer THEN + IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface))) + ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + END + ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN + DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1))) + ELSE DevCPM.ObjW(SHORT(CHR(f))) + END; + IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END; + OutName(obj.name^) + END + END ; + OutRefs(obj.right) + END + END OutRefs; + + PROCEDURE OutSourceRef* (pos: INTEGER); + BEGIN + IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN + WHILE pc > codePos + 250 DO + DevCPM.ObjW(SHORT(CHR(250))); + INC(codePos, 250); + DevCPM.ObjWNum(0) + END; + DevCPM.ObjW(SHORT(CHR(pc - codePos))); + codePos := pc; + DevCPM.ObjWNum(pos - srcPos); + srcPos := pos + END + END OutSourceRef; + + + PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER); + BEGIN + WHILE link # NIL DO + ASSERT(link.linkadr # 0); + DevCPM.ObjWNum(link.linkadr); + DevCPM.ObjWNum(adr + link.offset); + link := link.next + END + END OutPLink; + + PROCEDURE OutLink (link: DevCPT.LinkList); + BEGIN + OutPLink(link, 0); DevCPM.ObjW(0X) + END OutLink; + + PROCEDURE OutNames; + VAR a, b, c: DevCPT.Object; + BEGIN + a := nameList; b := NIL; + WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END; + DevCPM.ObjW(0X); (* names[0] = 0X *) + WHILE b # NIL DO + OutName(b.name^); + b := b.nlink + END; + END OutNames; + + PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR); + + PROCEDURE Copy (n: INTEGER); + VAR x, y: INTEGER; + BEGIN + x := ORD(str[n]); y := ORD(str[n + 1]); + IF x >= ORD("a") THEN DEC(x, ORD("a") - 10) + ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10) + ELSE DEC(x, ORD("0")) + END; + IF y >= ORD("a") THEN DEC(y, ORD("a") - 10) + ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10) + ELSE DEC(y, ORD("0")) + END; + DevCPM.ObjW(SHORT(CHR(x * 16 + y))) + END Copy; + + BEGIN + IF bigEndian THEN + Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17) + ELSE + Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15) + END; + Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35) + END OutGuid; + + PROCEDURE OutConst (obj: DevCPT.Object); + TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR; + VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER; + BEGIN + a := obj.conval; b := NIL; + WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END; + WHILE b # NIL DO + IF String8 IN b.setval THEN + DevCPM.ObjWBytes(b.ext^, b.intval2); + Align(4) + ELSIF String16 IN b.setval THEN + i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0; + Align(4) + ELSIF Real32 IN b.setval THEN + r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r); + IF DevCPM.LEHost = bigEndian THEN + ch := a4[0]; a4[0] := a4[3]; a4[3] := ch; + ch := a4[1]; a4[1] := a4[2]; a4[2] := ch + END; + DevCPM.ObjWBytes(a4, 4) + ELSIF Real64 IN b.setval THEN + a8 := SYSTEM.VAL(A8, b.realval); + IF DevCPM.LEHost = bigEndian THEN + ch := a8[0]; a8[0] := a8[7]; a8[7] := ch; + ch := a8[1]; a8[1] := a8[6]; a8[6] := ch; + ch := a8[2]; a8[2] := a8[5]; a8[5] := ch; + ch := a8[3]; a8[3] := a8[4]; a8[4] := ch + END; + DevCPM.ObjWBytes(a8, 8) + ELSIF Int64 IN b.setval THEN + (* intval moved to intval2 by AllocConst *) + x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x; + IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END + ELSIF Guid IN b.setval THEN + OutGuid(b.ext^) + END; + b := b.link + END + END OutConst; + + PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN); + BEGIN + IF typ = NIL THEN Out4(0) + ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr) + ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec) + ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr) + ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid) + ELSIF typ = DevCPT.restyp THEN Out4(mResult) + ELSE + CASE typ.form OF + | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0) + | Bool, Char8: Out4(typ.form - 1) + | Int8..Set: Out4(typ.form) + | Char16: Out4(mChar16) + | Int64: Out4(mInt64) + | ProcTyp: OutReference(TypeObj(typ), 0, absolute) + | Pointer: + IF typ.sysflag = interface THEN Out4(mInterface) + ELSIF typ.untagged THEN Out4(mSysPtr) + ELSE OutReference(TypeObj(typ), 0, absolute) + END + | Comp: + IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute) + ELSE Out4(0) + END + END + END + END OutStruct; + + PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER; + VAR n: INTEGER; + BEGIN + n := 0; + IF obj.name # DevCPT.null THEN + IF obj.num = 0 THEN + obj.num := namex; + WHILE obj.name[n] # 0X DO INC(n) END; + INC(namex, n + 1); + obj.nlink := nameList; nameList := obj + END; + n := obj.num; + END; + RETURN n + END NameIdx; + + PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER); + VAR p: DevCPT.Object; n, m: INTEGER; + BEGIN + pos := DevCPM.ObjLen() - headSize; + OutStruct(retTyp, TRUE); + p := par; n := 0; + WHILE p # NIL DO INC(n); p := p.link END; + Out4(n); p := par; + WHILE p # NIL DO + IF p.mode # VarPar THEN m := mValue + ELSIF p.vis = inPar THEN m := mInPar + ELSIF p.vis = outPar THEN m := mOutPar + ELSE m := mVarPar + END; + Out4(NameIdx(p) * 256 + m); + OutStruct(p.typ, TRUE); + p := p.link + END + END OutSignature; + + PROCEDURE PrepObject (obj: DevCPT.Object); + BEGIN + IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *) + OutSignature(obj.link, obj.typ, obj.conval.intval) + END + END PrepObject; + + PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object); + VAR vis: INTEGER; + BEGIN + Out4(fprint); + Out4(offs); + IF obj.vis = internal THEN vis := mInternal + ELSIF obj.vis = externalR THEN vis := mReadonly + ELSIF obj.vis = external THEN vis := mExported + END; + Out4(mode + vis * 16 + NameIdx(obj) * 256); + IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *) + ELSE OutStruct(typ, mode = mField) + END + END OutObject; + + PROCEDURE PrepDesc (desc: DevCPT.Struct); + VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct; + BEGIN + IF desc.comp = Record THEN (* write field list *) + desc.strobj.adr := DevCPM.ObjLen() - headSize; + n := 0; fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN INC(n) END; + fld := fld.link + END; + Out4(n); fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN + OutObject(mField, 0, fld.adr, fld.typ, fld) + END; + fld := fld.link + END + ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *) + OutSignature(desc.link, desc.BaseTyp, desc.n) + END; + (* assert name and base type are included *) + IF desc.untagged THEN n := NameIdx(untgd) + ELSE n := NameIdx(desc.strobj) + END; + IF desc.form # ProcTyp THEN b := desc.BaseTyp; + IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp}) + & (b.sysflag # interface) & (b # DevCPT.guidtyp) + & (~b.untagged OR outURef & (b.form = Comp)) THEN + l := OffsetLink(TypeObj(b), 0) + END + END + END PrepDesc; + + PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END; + obj := NumMeth(root.left, num); + IF obj = NIL THEN obj := NumMeth(root.right, num) END; + RETURN obj + END NumMeth; + + PROCEDURE OutDesc (desc: DevCPT.Struct); + VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE; + name: DevCPT.Name; + BEGIN + ASSERT(~desc.untagged); + IF desc.comp = Record THEN + xb := desc; flddir := desc.strobj.adr; + REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged; + Out4(-1); i := desc.n; + WHILE i > 0 DO DEC(i); t := desc; + REPEAT + m := NumMeth(t.link, i); t := t.BaseTyp + UNTIL (m # NIL) OR (t = xb); + IF m # NIL THEN + IF absAttr IN m.conval.setval THEN Out4(0) + ELSE OutReference(m, 0, absolute) + END + ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *) + ELSE OutReference(xb.strobj, -4 - 4 * i, copy) + END + END; + desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *) + Out4(desc.size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + IF desc.attribute = extAttr THEN attr := 1 + ELSIF desc.attribute = limAttr THEN attr := 2 + ELSIF desc.attribute = absAttr THEN attr := 3 + ELSE attr := 0 + END; + Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0; + WHILE i <= desc.extlev DO + t := desc; + WHILE t.extlev > i DO t := t.BaseTyp END; + IF t.sysflag = interface THEN Out4(0) + ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute) + ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute) + ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute) + ELSE OutReference(xb.strobj, 12 + 4 * i, copy) + END; + INC(i) + END; + WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END; + OutReference(Meta, flddir, absolute); (* ref to field list *) + nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr); + Out4(-(4 * nofptr + 4)); + nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr); + Out4(-1) + ELSE + desc.strobj.adr := DevCPM.ObjLen() - headSize; + lev := 0; size := 0; + IF desc.comp = Array THEN + size := desc.n; form := mArray + ELSIF desc.comp = DynArr THEN + form := mArray; lev := SHORT(SHORT(desc.n + 1)) + ELSIF desc.form = Pointer THEN + form := mPointer + ELSE ASSERT(desc.form = ProcTyp); + DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp; + END; + Out4(size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + Out4(form + lev * 16 + NameIdx(m) * 256); + IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE) + ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *) + END + END + END OutDesc; + + PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER); + VAR i: INTEGER; (* t: Dates.Time; d: Dates.Date; *) + BEGIN + Out4(0); (* link *) + Out4(ORD(options)); (* opts *) + Out4(0); (* refcnt *) + (* Dates.GetDate(d); Dates.GetTime(t); (* compile time *) + Out2(d.year); Out2(d.month); Out2(d.day); + Out2(t.hour); Out2(t.minute); Out2(t.second); *) + Out2(2007); Out2(5); Out2(25); + Out2(0); Out2(0); Out2(0); + Out4(0); Out4(0); Out4(0); (* load time *) + Out4(0); (* ext *) + IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *) + ELSE Out4(0) + END; + Out4(imports); (* nofimps *) + Out4(nofptr); (* nofptrs *) + Out4(pc); (* csize *) + Out4(dsize); (* dsize *) + Out4(refSize); (* rsize *) + OutReference(Code, 0, absolute); (* code *) + OutReference(Data, 0, absolute); (* data *) + OutReference(Meta, 0, absolute); (* refs *) + IF procVarIndirect THEN + OutReference(Proc, 0, absolute); (* procBase *) + ELSE + OutReference(Code, 0, absolute); (* procBase *) + END; + OutReference(Data, 0, absolute); (* varBase *) + OutReference(Meta, namePos, absolute); (* names *) + OutReference(Meta, ptrPos, absolute); (* ptrs *) + OutReference(Meta, impPos, absolute); (* imports *) + OutReference(Meta, expPos, absolute); (* export *) + i := 0; (* name *) + WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END; + DevCPM.ObjW(0X); + Align(4) + END OutModDesc; + + PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *) + BEGIN + IF obj # NIL THEN + OutProcTable(obj.left); + IF obj.mode IN {XProc, IProc} THEN + Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0); + END; + OutProcTable(obj.right); + END; + END OutProcTable; + + PROCEDURE PrepExport (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + PrepExport(obj.left); + IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN + PrepObject(obj) + END; + PrepExport(obj.right) + END + END PrepExport; + + PROCEDURE OutExport (obj: DevCPT.Object); + VAR num: INTEGER; + BEGIN + IF obj # NIL THEN + OutExport(obj.left); + IF (obj.history # removed) & ((obj.vis # internal) OR + (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN + DevCPT.FPrintObj(obj); + IF obj.mode IN {LProc, XProc, IProc} THEN + IF procVarIndirect THEN + ASSERT(obj.nlink = NIL); + num := obj.num; obj.num := 0; + OutObject(mProc, obj.fprint, num, NIL, obj); + obj.num := num + ELSE + OutObject(mProc, obj.fprint, obj.adr, NIL, obj) + END + ELSIF obj.mode = Var THEN + OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj) + ELSIF obj.mode = Typ THEN + OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj) + ELSE ASSERT(obj.mode IN {Con, CProc}); + OutObject(mConst, obj.fprint, 0, NIL, obj) + END + END; + OutExport(obj.right) + END + END OutExport; + + PROCEDURE OutCLinks (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + OutCLinks(obj.left); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END; + OutCLinks(obj.right) + END + END OutCLinks; + + PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER); + BEGIN + IF obj # NIL THEN + OutCPLinks(obj.left, base); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END; + OutCPLinks(obj.right, base) + END + END OutCPLinks; + + PROCEDURE OutImport (obj: DevCPT.Object); + VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER; + BEGIN + IF obj # NIL THEN + OutImport(obj.left); + IF obj.mode = Typ THEN typ := obj.typ; + IF obj.used OR + (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) & + ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN + DevCPT.FPrintStr(typ); + DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^); + IF obj.used THEN opt := 2 ELSE opt := 0 END; + IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN + DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1))); + IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END + ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt))) + END; + OutLink(obj.links) + END + ELSIF obj.used THEN + DevCPT.FPrintObj(obj); + IF obj.mode = Var THEN + DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSIF obj.mode IN {XProc, IProc} THEN + DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSE ASSERT(obj.mode IN {Con, CProc}); + DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint) + END + END; + OutImport(obj.right) + END + END OutImport; + + PROCEDURE OutUseBlock; + VAR m, obj: DevCPT.Object; i: INTEGER; + BEGIN + m := dllList; + WHILE m # NIL DO + obj := m.nlink; + WHILE obj # NIL DO + IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))) + ELSE DevCPM.ObjW(SHORT(CHR(mProc))) + END; + IF obj.entry # NIL THEN OutName(obj.entry^) + ELSE OutName(obj.name^); + END; + DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links); + obj := obj.nlink + END; + DevCPM.ObjW(0X); m := m.link + END; + i := 1; + WHILE i < DevCPT.nofGmod DO + obj := DevCPT.GlbMod[i]; + IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END; + INC(i) + END; + END OutUseBlock; + + PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String); + VAR name: DevCPT.String; dll: DevCPT.Object; + BEGIN + IF obj # NIL THEN + CollectDll(obj.left, mod); + IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN + IF obj.library # NIL THEN name := obj.library + ELSE name := mod + END; + dll := dllList; + WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END; + IF dll = NIL THEN + NEW(dll); dll.library := name; INC(imports); + IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END; + dllLast := dll; dll.left := dll; + END; + dll.left.nlink := obj; dll.left := obj + END; + CollectDll(obj.right, mod) + END + END CollectDll; + + PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER); + BEGIN + IF obj # NIL THEN + EnumXProc(obj.left, num); + IF obj.mode IN {XProc, IProc} THEN + obj.num := num; INC(num, 8); + END; + EnumXProc(obj.right, num) + END; + END EnumXProc; + + PROCEDURE OutHeader*; + VAR i: INTEGER; m: DevCPT.Object; + BEGIN + DevCPM.ObjWLInt(processor); (* processor type *) + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *) + imports := 0; i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library # NIL THEN (* dll import *) + CollectDll(m.right, m.library); + ELSE INC(imports) (* module import *) + END; + INC(i) + END; + DevCPM.ObjWNum(imports); (* num of import *) + OutName(DevCPT.SelfName); + m := dllList; + WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END; + i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library = NIL THEN OutName(m.name^) END; + INC(i) + END; + Align(16); headSize := DevCPM.ObjLen(); + IF procVarIndirect THEN + i := 0; EnumXProc(DevCPT.topScope.right, i) + END + END OutHeader; + + PROCEDURE OutCode*; + VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos, + con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER; + m, obj, dlist: DevCPT.Object; + BEGIN + (* Ref *) + DevCPM.ObjW(0X); (* end mark *) + refSize := DevCPM.ObjLen() - headSize; + (* Export *) + Align(4); + IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *) + Align(8); expPos := DevCPM.ObjLen(); + Out4(0); + OutExport(DevCPT.topScope.right); (* export objects *) + i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i); + (* Pointers *) + ptrPos := DevCPM.ObjLen(); + obj := DevCPT.topScope.scope; nofptrs := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END; + obj := DevCPT.topScope.scope; i := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END; + IF i > 0 THEN Out4(-1); INCL(options, iptrs) END; + (* Prepare Type Descriptors *) + dlist := NIL; + WHILE descList # NIL DO + obj := descList; descList := descList.link; + PrepDesc(obj.typ); + obj.link := dlist; dlist := obj + END; + (* Import List *) + impPos := DevCPM.ObjLen(); i := 0; + WHILE i < imports DO Out4(0); INC(i) END; + (* Names *) + namePos := DevCPM.ObjLen(); OutNames; + (* Const *) + Align(4); con8Pos := DevCPM.ObjLen(); + OutConst(Const8); con16Pos := DevCPM.ObjLen(); + ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8); + OutConst(Const16); con32Pos := DevCPM.ObjLen(); + ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16); + OutConst(Const32); con64Pos := DevCPM.ObjLen(); + ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32); + IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END; + OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64); + (* Module Descriptor *) + Align(16); modPos := DevCPM.ObjLen(); + OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize); + (* Procedure Table *) + procPos := DevCPM.ObjLen(); + OutProcTable(DevCPT.topScope.right); + Out4(0); Out4(0); (* at least one entry in ProcTable *) + Out4(0); (* sentinel *) + (* Type Descriptors *) + obj := dlist; + WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END; + (* Code *) + codePos := DevCPM.ObjLen(); WriteCode; + WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END; + (* Fixups *) + OutLink(KNewRec.links); OutLink(KNewArr.links); + (* metalink *) + OutPLink(Const8.links, con8Pos - headSize); + OutPLink(Const16.links, con16Pos - headSize); + OutPLink(Const32.links, con32Pos - headSize); + OutPLink(Const64.links, con64Pos - headSize); + OutLink(Meta.links); + (* desclink *) + obj := dlist; i := modPos - headSize; + WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END; + IF procVarIndirect THEN + OutPLink(Proc.links, procPos - modPos); + OutCPLinks(DevCPT.topScope.right, procPos - modPos) + END; + OutLink(Mod.links); + (* codelink *) + IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END; + OutPLink(CaseLinks, 0); OutLink(Code.links); + (* datalink *) + OutLink(Data.links); + (* Use *) + OutUseBlock; + (* Header Fixups *) + DevCPM.ObjSet(8); + DevCPM.ObjWLInt(headSize); + DevCPM.ObjWLInt(modPos - headSize); + DevCPM.ObjWLInt(codePos - modPos); + DevCPM.ObjWLInt(pc); + DevCPM.ObjWLInt(dsize); + IF namex > MaxNameTab THEN DevCPM.err(242) END; + IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END + END OutCode; + + PROCEDURE Init* (proc: INTEGER; opt: SET); + CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14; + BEGIN + processor := proc; + bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt; + outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt; + outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options); + outSrc := srcpos IN opt; + pc := 0; actIdx := CodeLength; blkIdx := 0; + idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1; + options := opt * {0..15}; CodeOvF := FALSE; + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + codePos := 0; srcPos := 0; + NEW(untgd); untgd.name := DevCPT.NewName("!"); + closeLbl := 0 + END Init; + + PROCEDURE Close*; + BEGIN + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END; + actual := NIL; untgd := NIL; + END Close; + +BEGIN + NEW(KNewRec); KNewRec.mnolev := -128; + NEW(KNewArr); KNewArr.mnolev := -128; + NEW(Const8); Const8.mode := Con; Const8.mnolev := 0; + NEW(Const16); Const16.mode := Con; Const16.mnolev := 0; + NEW(Const32); Const32.mode := Con; Const32.mnolev := 0; + NEW(Const64); Const64.mode := Con; Const64.mnolev := 0; + NEW(Code); Code.mode := Con; Code.mnolev := 0; + NEW(Data); Data.mode := Con; Data.mnolev := 0; + NEW(Mod); Mod.mode := Con; Mod.mnolev := 0; + NEW(Proc); Proc.mode := Con; Proc.mnolev := 0; + NEW(Meta); Meta.mode := Con; Mod.mnolev := 0; +END Dev0CPE. diff --git a/Trurl-based/Dev0/Mod/CPH.odc b/Trurl-based/Dev0/Mod/CPH.odc new file mode 100644 index 0000000..4dcb383 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPH.odc differ diff --git a/Trurl-based/Dev0/Mod/CPH.txt b/Trurl-based/Dev0/Mod/CPH.txt new file mode 100644 index 0000000..3d57237 --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPH.txt @@ -0,0 +1,304 @@ +MODULE Dev0CPH; + + (* THIS IS TEXT COPY OF CPH.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPT := Dev0CPT; + + CONST + (* UseCalls options *) + longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3; + realMop* = 8; realDop* = 9; realConv* = 10; + intMulDiv* = 11; + force = 16; hide = 17; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + + + PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR); + VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN; + BEGIN + IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real" + ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal" + ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long" + ELSE mod := "Int" + END; + moda := mod + "%"; + DevCPT.Find(moda, mobj); + IF mobj = NIL THEN + DevCPT.Import(moda, mod, done); + IF done THEN DevCPT.Find(moda, mobj) END + END; + nm := name$; DevCPT.FindImport(nm, mobj, obj); + n.class := Ncall; n.subcl := 0; n.obj := obj.link; + n.left.link := n.right; n.right := n.left; + n.left := DevCPT.NewNode(Nproc); + n.left.obj := obj; n.left.typ := obj.typ; + ASSERT(n.typ.form = obj.typ.form) + END UseThisCall; + + PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct); + VAR new: DevCPT.Node; r: REAL; + BEGIN + IF n.class = Nconst THEN + ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp)); + r := n.conval.realval + n.conval.intval; + IF r = n.conval.realval + n.conval.intval THEN + n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL + END + END; + IF (n.typ # typ) + & ((n.class # Nmop) OR (n.subcl # conv) + OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN + new := DevCPT.NewNode(0); new^ := n^; + n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL + END; + n.typ := typ + END Convert; + + PROCEDURE UseCallForComp (n: DevCPT.Node); + VAR new: DevCPT.Node; + BEGIN + new := DevCPT.NewNode(0); + new.left := n.left; new.right := n.right; + new.typ := DevCPT.int32typ; + UseThisCall(new, "Comp"); + n.left := new; + n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst(); + n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ; + END UseCallForComp; + + PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET); + VAR f, g: INTEGER; typ: DevCPT.Struct; + BEGIN + typ := n.typ; f := typ.form; g := n.left.typ.form; + IF realConv IN opts THEN + IF f IN realSet THEN + IF g = Real32 THEN UseThisCall(n, "Long") + ELSIF g = Real64 THEN UseThisCall(n, "Short") + ELSIF g = Int64 THEN UseThisCall(n, "LFloat") + ELSIF g = Int32 THEN UseThisCall(n, "Float") + ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float") + END + ELSIF g IN realSet THEN + IF f = Int64 THEN UseThisCall(n, "LFloor") + ELSIF f = Int32 THEN UseThisCall(n, "Floor") + ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ) + END + END + END; + IF longConv IN opts THEN + IF f = Int64 THEN + IF g = Int32 THEN UseThisCall(n, "Long") + ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong") + END + ELSIF g = Int64 THEN + IF f = Int32 THEN UseThisCall(n, "Short") + ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ) + END + END + END + END UseCallForConv; + + PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET); + BEGIN + CASE n.subcl OF + | minus: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Neg") + END + | abs: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Abs") + END + | odd: + IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END + | conv: + UseCallForConv(n, opts) + ELSE + END + END UseCallForMop; + + PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET); + BEGIN + IF (realDop IN opts) & (n.left.typ.form IN realSet) + OR (longDop IN opts) & (n.left.typ.form = Int64) + OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN + CASE n.subcl OF + | times: UseThisCall(n, "Mul") + | slash: UseThisCall(n, "Div") + | div: UseThisCall(n, "Div") + | mod: UseThisCall(n, "Mod") + | plus: UseThisCall(n, "Add") + | minus: UseThisCall(n, "Sub") + | ash: UseThisCall(n, "Ash") + | min: UseThisCall(n, "Min") + | max: UseThisCall(n, "Max") + | eql..geq: UseCallForComp(n) + ELSE + END + END + END UseCallForDop; + + PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET); + VAR f, g: INTEGER; + BEGIN + f := n.typ.form; g := typ.form; + IF f # g THEN + IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet)) + OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN + Convert(n, typ); + UseCallForConv(n, opts) + END + END + END UseCallForMove; + + PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET); + BEGIN + IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END + END UseCallForAssign; + + PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET); + BEGIN + IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END + END UseCallForReturn; + + PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET); + BEGIN + WHILE n # NIL DO + UseCallForMove(n, fp.typ, opts); + n := n.link; fp := fp.link + END + END UseCallForParam; + + PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + UseCalls(n.left, opts); UseCallForMop(n, opts) + | Ndop: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts) + | Ncase: + UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts) + | Nassign: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts) + | Ncall: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts) + | Nreturn: + UseCalls(n.left, opts); UseCallForReturn(n, opts) + | Ncasedo: + UseCalls(n.right, opts) + | Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard: + UseCalls(n.left, opts) + | Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseCalls(n.left, opts); UseCalls(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END UseCalls; + + + PROCEDURE UseReals* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN + UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp + ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide}) + ELSE UseReals(n.left, opts - {force, hide}) + END + | Ndop: + IF (longDop IN opts) & (n.left.typ.form = Int64) THEN + UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force}); + IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END + ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + END + | Ncase: + UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide}); + UseReals(n.right.right, opts - {force, hide}) + | Ncasedo: + UseReals(n.right, opts - {force, hide}) + | Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard: + UseReals(n.left, opts - {force, hide}) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + IF force IN opts THEN Convert(n, DevCPT.intrealtyp) + ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ) + END; + n := n.link + END + END UseReals; + +END Dev0CPH. + + + + + PROCEDURE Traverse (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Ncase: + Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts) + | Ncasedo: + Traverse(n.right, opts) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + Traverse(n.left, opts) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + Traverse(n.left, opts); Traverse(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END Traverse; + diff --git a/Trurl-based/Dev0/Mod/CPL486.odc b/Trurl-based/Dev0/Mod/CPL486.odc new file mode 100644 index 0000000..b96a99c Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPL486.odc differ diff --git a/Trurl-based/Dev0/Mod/CPL486.txt b/Trurl-based/Dev0/Mod/CPL486.txt new file mode 100644 index 0000000..0c2987a --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPL486.txt @@ -0,0 +1,1070 @@ +MODULE Dev0CPL486; + + (* THIS IS TEXT COPY OF CPL486.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPE := Dev0CPE; + + TYPE + Item* = RECORD + mode*, tmode*, form*: BYTE; + offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *) + typ*: DevCPT.Struct; + obj*: DevCPT.Object + END ; + +(* Items: + + mode | offset index scale reg obj +------------------------------------------------ + 1 Var | adr xreg scale obj (ea = FP + adr + xreg * scale) + 2 VarPar| off xreg scale obj (ea = [FP + obj.adr] + off + xreg * scale) + 3 Con | val (val2) NIL + Con | off obj (val = adr(obj) + off) + Con | id NIL (for predefined reals) + 6 LProc | obj + 7 XProc | obj + 9 CProc | obj +10 IProc | obj +13 TProc | mthno 0/1 obj (0 = normal / 1 = super call) +14 Ind | off xreg scale Reg (ea = Reg + off + xreg * scale) +15 Abs | adr xreg scale NIL (ea = adr + xreg * scale) + Abs | off xreg scale obj (ea = adr(obj) + off + xreg * scale) + Abs | off len 0 obj (for constant strings and reals) +16 Stk | (ea = ESP) +17 Cond | CC +18 Reg | (Reg2) Reg +19 DInd | off xreg scale Reg (ea = [Reg + off + xreg * scale]) + + tmode | record tag array desc +------------------------------------- + VarPar | [FP + obj.adr + 4] [FP + obj.adr] + Ind | [Reg - 4] [Reg + 8] + Con | Adr(typ.strobj) + +*) + + CONST + processor* = 10; (* for i386 *) + NewLbl* = 0; + + TYPE + Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *) + + VAR + level*: BYTE; + one*: DevCPT.Const; + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 (must not overlap item basemodes, > 13) *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + + VAR + Size: ARRAY 32 OF INTEGER; (* Size[typ.form] == +/- typ.size *) + a1, a2: Item; + + + PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE); + BEGIN + ASSERT((reg >= 0) & (reg < 8)); + x.mode := Reg; x.reg := reg; x.form := form + END MakeReg; + + PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE); + BEGIN + x.mode := Con; x.offset := val; x.form := form; x.obj := NIL; + END MakeConst; + + PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE); + VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER; + BEGIN + IF form IN {Real32, Real64} THEN + r := con.realval; + IF ABS(r) <= MAX(SHORTREAL) THEN + short := SHORT(r); + IF short = r THEN form := Real32 (* a shortreal can represent the exact value *) + ELSE form := Real64 (* use a real *) + END + ELSE form := Real64 (* use a real *) + END + ELSIF form IN {String8, String16, Guid} THEN + x.index := con.intval2 (* string length *) + END; + DevCPE.AllocConst(con, form, x.obj, x.offset); + x.form := form; x.mode := Abs; x.scale := 0 + END AllocConst; + + (*******************************************************) + + PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *) + BEGIN + END BegStat; + + PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *) + BEGIN + END EndStat; + + (*******************************************************) + + PROCEDURE SetLabel* (VAR L: Label); + VAR link, typ, disp, x: INTEGER; c: SHORTCHAR; + BEGIN + ASSERT(L <= 0); link := -L; + WHILE link # 0 DO + typ := link DIV 1000000H; link := link MOD 1000000H; + IF typ = short THEN + disp := DevCPE.pc - link - 1; ASSERT(disp < 128); + DevCPE.PutByte(link, disp); link := 0 + ELSIF typ = relative THEN + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x + ELSE + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x + END + END; + L := DevCPE.pc; + a1.mode := 0; a2.mode := 0 + END SetLabel; + + + (*******************************************************) + + PROCEDURE GenWord (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256) + END GenWord; + + PROCEDURE GenDbl (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H) + END GenDbl; + + PROCEDURE CaseEntry* (tab, from, to: INTEGER); + VAR a, e: INTEGER; + BEGIN + a := tab + 4 * from; e := tab + 4 * to; + WHILE a <= e DO + DevCPE.PutByte(a, DevCPE.pc); + DevCPE.PutByte(a + 1, DevCPE.pc DIV 256); + DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536); + INC(a, 4) + END; + a1.mode := 0; a2.mode := 0 + END CaseEntry; + + PROCEDURE GenLinked (VAR x: Item; type: BYTE); + VAR link: DevCPT.LinkList; + BEGIN + IF x.obj = NIL THEN GenDbl(x.offset) + ELSE + link := DevCPE.OffsetLink(x.obj, x.offset); + IF link # NIL THEN + GenDbl(type * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := DevCPE.pc - 4 + ELSE GenDbl(0) + END + END + END GenLinked; + + PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER); + BEGIN + IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1 + ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1 + ELSE w := 0 + END + END CheckSize; + + PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER); + BEGIN + IF form = Real32 THEN mf := 0 + ELSIF form = Real64 THEN mf := 4 + ELSIF form = Int32 THEN mf := 2 + ELSE ASSERT(form = Int16); mf := 6 + END + END CheckForm; + + PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER); + BEGIN + IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2 + ELSE s := 0 + END + END CheckConst; + + PROCEDURE GenConst (VAR x: Item; short: BOOLEAN); + BEGIN + IF x.obj # NIL THEN GenLinked(x, absolute) + ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset) + ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset) + ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset) + ELSE GenDbl(x.offset) + END + END GenConst; + + PROCEDURE GenCExt (code: INTEGER; VAR x: Item); + VAR disp, mod, base, scale: INTEGER; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs, Stk}); + ASSERT((code MOD 8 = 0) & (code < 64)); + disp := x.offset; base := x.reg; scale := x.scale; + IF x.mode = Reg THEN mod := 0C0H; scale := 0 + ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0 + ELSIF x.mode = Abs THEN + IF scale = 1 THEN base := x.index; mod := 80H; scale := 0 + ELSE base := BP; mod := 0 + END + ELSIF (disp = 0) & (base # BP) THEN mod := 0 + ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H + ELSE mod := 80H + END; + IF scale # 0 THEN + DevCPE.GenByte(mod + code + 4); base := base + x.index * 8; + IF scale = 8 THEN DevCPE.GenByte(0C0H + base); + ELSIF scale = 4 THEN DevCPE.GenByte(80H + base); + ELSIF scale = 2 THEN DevCPE.GenByte(40H + base); + ELSE ASSERT(scale = 1); DevCPE.GenByte(base); + END; + ELSE + DevCPE.GenByte(mod + code + base); + IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END + END; + IF x.mode = Abs THEN GenLinked(x, absolute) + ELSIF mod = 80H THEN GenDbl(disp) + ELSIF mod = 40H THEN DevCPE.GenByte(disp) + END + END GenCExt; + + PROCEDURE GenDExt (VAR r, x: Item); + BEGIN + ASSERT(r.mode = Reg); + GenCExt(r.reg * 8, x) + END GenDExt; + + (*******************************************************) + + PROCEDURE GenMove* (VAR from, to: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[from.form] = Size[to.form]); + IF to.mode = Reg THEN + IF from.mode = Con THEN + IF to.reg = AX THEN + + IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0 + END; + CheckSize(from.form, w); + IF (from.offset = 0) & (from.obj = NIL) THEN + DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *) + ELSE + DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE) + END; + ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN + + IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) + OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0; + CheckSize(from.form, w); + DevCPE.GenByte(0A0H + w); GenLinked(from, absolute); + ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN + IF to.reg = AX THEN + IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN + + IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form) + OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from + ELSE a1.mode := 0 + END; + a2.mode := 0 + END; + CheckSize(from.form, w); + DevCPE.GenByte(8AH + w); GenDExt(to, from) + END + ELSE + CheckSize(from.form, w); + IF from.mode = Con THEN + DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE); + a1.mode := 0; a2.mode := 0 + ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN + DevCPE.GenByte(0A2H + w); GenLinked(to, absolute); + a2 := to + ELSE + DevCPE.GenByte(88H + w); GenDExt(from, to); + IF from.reg = AX THEN + IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END + ELSE a1.mode := 0; a2.mode := 0 + END + END + END + END GenMove; + + PROCEDURE GenExtMove* (VAR from, to: Item); + VAR w, op: INTEGER; + BEGIN + ASSERT(from.mode # Con); + IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *) + ELSE op := 0BEH (* MOVSX *) + END; + IF from.form IN {Int16, Char16} THEN INC(op) END; + DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from); + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenExtMove; + + PROCEDURE GenSignExt* (VAR from, to: Item); + BEGIN + ASSERT(to.mode = Reg); + IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN + DevCPE.GenByte(99H) (* cdq *) + ELSE + GenMove(from, to); (* mov to, from *) + DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31) (* sar to, 31 *) + END + END GenSignExt; + + PROCEDURE GenLoadAdr* (VAR from, to: Item); + BEGIN + ASSERT(to.form IN {Int32, Pointer, ProcTyp}); + IF (from.mode = Abs) & (from.scale = 0) THEN + DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute) + ELSIF from.mode = Stk THEN + DevCPE.GenByte(89H); GenCExt(SP * 8, to) + ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN + DevCPE.GenByte(8DH); GenDExt(to, from) + ELSIF from.reg # to.reg THEN + DevCPE.GenByte(89H); GenCExt(from.reg * 8, to) + ELSE RETURN + END; + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenLoadAdr; + + PROCEDURE GenPush* (VAR src: Item); + VAR s: INTEGER; + BEGIN + IF src.mode = Con THEN + ASSERT(src.form >= Int32); + CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE) + ELSIF src.mode = Reg THEN + ASSERT((src.form >= Int16) OR (src.reg < 4)); + DevCPE.GenByte(50H + src.reg) + ELSE + ASSERT(src.form >= Int32); + DevCPE.GenByte(0FFH); GenCExt(30H, src) + END + END GenPush; + + PROCEDURE GenPop* (VAR dst: Item); + BEGIN + IF dst.mode = Reg THEN + ASSERT((dst.form >= Int16) OR (dst.reg < 4)); + DevCPE.GenByte(58H + dst.reg); + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + ELSE + DevCPE.GenByte(08FH); GenCExt(0, dst) + END + END GenPop; + + PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item); + VAR w, s: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + CheckConst(src, s); + IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN + DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE) + ELSE + DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE) + END + END GenConOp; + + PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + IF dst.mode = Reg THEN + DevCPE.GenByte(op + 2 + w); GenDExt(dst, src) + ELSE + DevCPE.GenByte(op + w); GenDExt(src, dst) + END + END GenDirOp; + + PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(0, src, dst) + ELSE RETURN + END + ELSE + GenConOp(0, src, dst) + END + ELSE + GenDirOp(0, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAdd; + + PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 0 ELSE op := 10H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAddC; + + PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(28H, src, dst) + ELSE RETURN + END + ELSE + GenConOp(28H, src, dst) + END + ELSE + GenDirOp(28H, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSub; + + PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 28H ELSE op := 18H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSubC; + + PROCEDURE GenComp* (VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + IF src.mode = Con THEN + IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN + CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *) + ELSE GenConOp(38H, src, dst) + END + ELSE + GenDirOp(38H, src, dst) + END + END GenComp; + + PROCEDURE GenAnd* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END + ELSE GenDirOp(20H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAnd; + + PROCEDURE GenOr* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END + ELSE GenDirOp(8H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenOr; + + PROCEDURE GenXor* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END + ELSE GenDirOp(30H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenXor; + + PROCEDURE GenTest* (VAR x, y: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[x.form] = Size[y.form]); + CheckSize(x.form, w); + IF x.mode = Con THEN + IF (x.mode = Reg) & (x.reg = AX) THEN + DevCPE.GenByte(0A8H + w); GenConst(x, FALSE) + ELSE + DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE) + END + ELSE + DevCPE.GenByte(84H + w); + IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END + END + END GenTest; + + PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst); + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNeg; + + PROCEDURE GenNot* (VAR dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNot; + + PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w, s, val, f2, f5, f9: INTEGER; + BEGIN + ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form])); + IF (src.mode = Con) & (src.offset = 1) THEN RETURN END; + IF src.form <= Int8 THEN + ASSERT(dst.reg = 0); + DevCPE.GenByte(0F6H); GenCExt(28H, src) + ELSIF src.mode = Con THEN + val := src.offset; + IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN + f2 := 0; f5 := 0; f9 := 0; + WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END; + WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END; + WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END; + IF ABS(val) <= 3 THEN + WHILE f9 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(0C0H + dst.reg * 9); + DEC(f9) + END; + WHILE f5 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(80H + dst.reg * 9); + DEC(f5) + END; + IF ABS(val) = 3 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9) + END; + IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2) + ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9) + END; + IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END; + RETURN + END + END; + CheckSize(src.form, w); CheckConst(src, s); + DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE) + ELSE + CheckSize(src.form, w); + DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenMul; + + PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN); + VAR w, rem: INTEGER; + BEGIN + ASSERT(src.mode = Reg); + IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *) + ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *) + ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *) + END; + CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *) + IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END; + IF pos THEN (* src > 0 *) + CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + IF mod THEN + DevCPE.GenByte(79H); DevCPE.GenByte(2); (* jns end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); DevCPE.GenByte(1); (* jns end *) + DevCPE.GenByte(48H); (* dec eax *) + END + ELSE + CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + IF mod THEN + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(4); (* je end *) + DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(1); (* je end *) + DevCPE.GenByte(48H); (* dec eax *) + END +(* + CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *) + IF mod THEN + DevCPE.GenByte(72H); DevCPE.GenByte(4); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(2); (* jg end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(72H); DevCPE.GenByte(3); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(1); (* jg end *) + DevCPE.GenByte(48H); (* dec eax *) + END +*) + END; + a1.mode := 0; a2.mode := 0 + END GenDiv; + + PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); + IF cnt.mode = Con THEN + ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL); + IF cnt.offset = 1 THEN + IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *) + DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *) + ELSE + DevCPE.GenByte(0D0H + w); GenCExt(op, dst) + END + ELSIF cnt.offset > 1 THEN + DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset) + END + ELSE + ASSERT((cnt.mode = Reg) & (cnt.reg = CX)); + DevCPE.GenByte(0D2H + w); GenCExt(op, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenShiftOp; + + PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item); + BEGIN + DevCPE.GenByte(0FH); + IF num.mode = Con THEN + ASSERT(num.obj = NIL); + DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset) + ELSE + ASSERT((num.mode = Reg) & (num.form = Int32)); + DevCPE.GenByte(83H + op); GenDExt(num, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenBitOp; + + PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item); + BEGIN + ASSERT((dst.form = Bool) & (cc >= 0)); + DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSetCC; + + PROCEDURE GenFLoad* (VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Con THEN (* predefined constants *) + DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset) + ELSIF src.form = Int64 THEN + DevCPE.GenByte(0DFH); GenCExt(28H, src) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D9H + mf); GenCExt(0, src) + END + END GenFLoad; + + PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN); + VAR mf: INTEGER; + BEGIN + IF dst.form = Int64 THEN ASSERT(pop); + DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE + CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf); + IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE GenCExt(10H, dst) + END + END; + a1.mode := 0; a2.mode := 0 + END GenFStore; + + PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Reg THEN + DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D8H + mf); GenCExt(op, src) + END + END GenFDOp; + + PROCEDURE GenFMOp* (op: INTEGER); + BEGIN + DevCPE.GenByte(0D8H + op DIV 256); + DevCPE.GenByte(op MOD 256); + IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END (* FSTSW AX *) + END GenFMOp; + + PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN); + BEGIN + IF cc # ccNever THEN + IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN + IF cc = ccAlways THEN DevCPE.GenByte(0EBH) + ELSE DevCPE.GenByte(70H + cc) + END; + IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1) + ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0) + END + ELSE + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + IF L > 0 THEN GenDbl(L - DevCPE.pc - 4) + ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H) + END + END + END + END GenJump; + + PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item); + BEGIN + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + dst.offset := 0; GenLinked(dst, relative) + END GenExtJump; + + PROCEDURE GenIndJump* (VAR dst: Item); + BEGIN + DevCPE.GenByte(0FFH); GenCExt(20H, dst) + END GenIndJump; + + PROCEDURE GenCaseJump* (VAR src: Item); + VAR link: DevCPT.LinkList; tab: INTEGER; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + END GenCaseJump; +(* + PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT); + VAR link: DevCPT.LinkList; else, last: LONGINT; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + else := tab + num * 4; last := else - 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := CaseLinks; CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END; + GenDbl(tableend * 1000000H + else) + END GenCaseJump; +*) + PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN); + VAR typ: INTEGER; + BEGIN + IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END; + IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END + END GenCaseEntry; + + PROCEDURE GenCall* (VAR dst: Item); + BEGIN + IF dst.mode IN {LProc, XProc, IProc} THEN + DevCPE.GenByte(0E8H); + IF dst.obj.mnolev >= 0 THEN (* local *) + IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4) + ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H) + END + ELSE (* imported *) + dst.offset := 0; GenLinked(dst, relative) + END + ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst) + END; + a1.mode := 0; a2.mode := 0 + END GenCall; + + PROCEDURE GenAssert* (cc, no: INTEGER); + BEGIN + IF cc # ccAlways THEN + IF cc >= 0 THEN + DevCPE.GenByte(70H + cc); (* jcc end *) + IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END + END; + IF no < 0 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no) + ELSE + DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no) + END + END + END GenAssert; + + PROCEDURE GenReturn* (val: INTEGER); + BEGIN + IF val = 0 THEN DevCPE.GenByte(0C3H) + ELSE DevCPE.GenByte(0C2H); GenWord(val) + END; + a1.mode := 0; a2.mode := 0 + END GenReturn; + + PROCEDURE LoadStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *) + END LoadStr; + + PROCEDURE StoreStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *) + END StoreStr; + + PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF rep THEN DevCPE.GenByte(0F2H) END; + IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *) + END ScanStr; + + PROCEDURE TestNull (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *) + ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *) + END + END TestNull; + + PROCEDURE GenBlockMove* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *); + IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *) + END + END GenBlockMove; + + PROCEDURE GenBlockStore* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *); + IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *) + END + END GenBlockStore; + + PROCEDURE GenBlockComp* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + ASSERT(len >= 0); + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *) + END GenBlockComp; + + PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER); + (* + len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X + *) + VAR loop, end: Label; + BEGIN + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + (* len >= 0: len IN ECX *) + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *) + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + IF len < 0 THEN (* no limit *) + StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE); + IF excl THEN (* dec edi *) + DevCPE.GenByte(4FH); + IF dsize # 1 THEN DevCPE.GenByte(4FH) END + END; + ELSE (* cx limit *) + IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize) + ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE) + END; + DevCPE.GenByte(49H); (* dec ecx *) + GenJump(ccNE, loop, TRUE); + GenAssert(ccNever, copyTrap); (* trap *) + SetLabel(end) + END; + a1.mode := 0; a2.mode := 0 + END GenStringMove; + + PROCEDURE GenStringComp* (wsize, dsize: INTEGER); + (* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *) + VAR loop, end: Label; + BEGIN + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END; + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE); + IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *) + TestNull(wsize); GenJump(ccNE, loop, TRUE); + SetLabel(end); + a1.mode := 0; a2.mode := 0 + END GenStringComp; + + PROCEDURE GenStringLength* (wsize, len: INTEGER); (* len = 0: len in ECX, len = -1: len undefined *) + BEGIN + DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) + IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + ScanStr(wsize, TRUE); + a1.mode := 0; a2.mode := 0 + END GenStringLength; + + PROCEDURE GenStrStore* (size: INTEGER); + VAR w: INTEGER; + BEGIN + IF size # 0 THEN + IF size MOD 4 = 0 THEN w := 1; size := size DIV 4 + ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2 + ELSE w := 0 + END; + DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *) + IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END + ELSE w := 0 + END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + a1.mode := 0; a2.mode := 0 + END GenStrStore; + + PROCEDURE GenCode* (op: INTEGER); + BEGIN + DevCPE.GenByte(op); + a1.mode := 0; a2.mode := 0 + END GenCode; + + + PROCEDURE Init*(opt: SET); + BEGIN + DevCPE.Init(processor, opt); + level := 0; + NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc; + END Init; + + PROCEDURE Close*; + BEGIN + a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL; + DevCPE.Close + END Close; + +BEGIN + Size[Undef] := 0; + Size[Byte] := 1; + Size[Bool] := 1; + Size[Char8] := 1; + Size[Int8] := 1; + Size[Int16] := 2; + Size[Int32] := 4; + Size[Real32] := -4; + Size[Real64] := -8; + Size[Set] := 4; + Size[String8] := 0; + Size[NilTyp] := 4; + Size[NoTyp] := 0; + Size[Pointer] := 4; + Size[ProcTyp] := 4; + Size[Comp] := 0; + Size[Char16] := 2; + Size[Int64] := 8; + Size[String16] := 0 +END Dev0CPL486. diff --git a/Trurl-based/Dev0/Mod/CPM.odc b/Trurl-based/Dev0/Mod/CPM.odc new file mode 100644 index 0000000..0049d01 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPM.odc differ diff --git a/Trurl-based/Dev0/Mod/CPM.txt b/Trurl-based/Dev0/Mod/CPM.txt new file mode 100644 index 0000000..583483c --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPM.txt @@ -0,0 +1,809 @@ +MODULE Dev0CPM; + + (* THIS IS TEXT COPY OF CPM.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, Kernel, Files (* , Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers *); + + CONST + ProcSize* = 4; (* PROCEDURE type *) + PointerSize* = 4; (* POINTER type *) + DArrSizeA* = 8; (* dyn array descriptor *) + DArrSizeB* = 4; (* size = A + B * typ.n *) + + MaxSet* = 31; + MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *) + + MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *) + MinReal64PatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *) + MinReal64PatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *) + MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *) + MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *) + MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *) + InfRealPat = 07F800000H; (* real infinity pattern *) + + + (* inclusive range of parameter of standard procedure HALT *) + MinHaltNr* = 0; + MaxHaltNr* = 128; + + (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *) + MinRegNr* = 0; + MaxRegNr* = 31; + + (* maximal value of flag used to mark interface structures *) + MaxSysFlag* = 127; (* shortint *) + CProcFlag* = 1; (* code procedures *) + + (* maximal condition value of parameter of SYSTEM.CC *) + MaxCC* = 15; + + (* initialization of constant address, must be different from any valid constant address *) + ConstNotAlloc* = -1; + + (* whether hidden pointer fields have to be nevertheless exported *) + ExpHdPtrFld* = TRUE; + HdPtrName* = "@ptr"; + + (* whether hidden untagged pointer fields have to be nevertheless exported *) + ExpHdUtPtrFld* = TRUE; + HdUtPtrName* = "@utptr"; + + (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *) + ExpHdProcFld* = TRUE; + HdProcName* = "@proc"; + + (* whether hidden bound procedures have to be nevertheless exported *) + ExpHdTProc* = FALSE; + HdTProcName* = "@tproc"; + + (* maximal number of exported stuctures: *) + MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *) + + (* maximal number of record extensions: *) + MaxExts* = 15; (* defined by type descriptor layout *) + + (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *) + NEWusingAdr* = FALSE; + + (* special character (< " ") returned by procedure Get, if end of text reached *) + Eot* = 0X; + + (* warnings *) + longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7; + + (* language options *) + interface* = 1; + com* = 2; comAware* = 3; + som* = 4; somAware* = 5; + oberon* = 6; + java* = 7; javaAware* = 8; + noCode* = 9; + allSysVal* = 14; + sysImp* = 15; + trap* = 31; + sys386 = 10; sys68k = 20; (* processor type in options if system imported *) + + CONST + SFdir = "Sym"; + OFdir = "Code"; + SYSdir = "System"; + SFtag = 6F4F5346H; (* symbol file tag *) + OFtag = 6F4F4346H; (* object file tag *) + maxErrors = 64; + +TYPE + File = POINTER TO RECORD next: File; f: Files.File END; + + VAR + LEHost*: BOOLEAN; (* little or big endian host *) + MinReal32*, MaxReal32*, InfReal*, + MinReal64*, MaxReal64*: REAL; + noerr*: BOOLEAN; (* no error found until now *) + curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *) + searchpos*: INTEGER; (* search position in source file *) + errors*: INTEGER; + breakpc*: INTEGER; (* set by OPV.Init *) + options*: SET; (* language options *) + file*: Files.File; (* used for sym file import *) + codeDir*: ARRAY 16 OF CHAR; + symDir*: ARRAY 16 OF CHAR; + checksum*: INTEGER; (* symbol file checksum *) + + errorMes*: ARRAY 4096 OF CHAR; + + lastpos: INTEGER; + realpat: INTEGER; + lrealpat: RECORD H, L: INTEGER END; + fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR; + ObjFName: Files.Name; + + in: Files.Reader; + oldSymFile, symFile, objFile: Files.File; + inSym: Files.Reader; + outSym, outObj: Files.Writer; + + errNo-, errPos-: ARRAY maxErrors OF INTEGER; + + lineReader: Files.Reader; + lineNum: INTEGER; + + crc32tab: ARRAY 256 OF INTEGER; + + + PROCEDURE^ err* (n: INTEGER); + + PROCEDURE Init* (source: Files.Reader); + BEGIN + in := source; + noerr := TRUE; options := {}; + curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0; + codeDir := OFdir; symDir := SFdir; + errorMes := "" + END Init; + + PROCEDURE Close*; + BEGIN + oldSymFile := NIL; inSym := NIL; + symFile := NIL; outSym := NIL; + objFile := NIL; outObj := NIL; + in := NIL; lineReader := NIL + END Close; + + PROCEDURE Get* (VAR ch: SHORTCHAR); + VAR + ch1: BYTE; + BEGIN + REPEAT + in.ReadByte(ch1); + ch := SYSTEM.VAL(SHORTCHAR, ch1); + INC(curpos) + UNTIL (ch < 100X) + END Get; + + PROCEDURE GetL* (VAR ch: CHAR); + VAR + sCh: SHORTCHAR; + BEGIN + Get(sCh); + ch := sCh + END GetL; + +(* + PROCEDURE LineOf* (pos: INTEGER): INTEGER; + VAR ch: CHAR; + BEGIN + IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END; + IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END; + WHILE lineReader.Pos() < pos DO + lineReader.ReadChar(ch); + IF ch = 0DX THEN INC(lineNum) END + END; + RETURN lineNum + END LineOf; +*) + + PROCEDURE LoWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF ~LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END LoWord; + + PROCEDURE HiWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END HiWord; + + PROCEDURE Compound (lo, hi: INTEGER): REAL; + VAR r: REAL; + BEGIN + IF LEHost THEN + SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi) + ELSE + SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi) + END; + RETURN r + END Compound; + + + (* sysflag control *) + + PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN; + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN + IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END; + i := 1; + WHILE i < 37 DO + ch := str[i]; + IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN + IF ch # "-" THEN RETURN FALSE END + ELSE + IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END + END; + INC(i) + END; + RETURN TRUE + END ValidGuid; + + PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF id # "" THEN + IF id = "code" THEN num := 1 + ELSIF id = "callback" THEN num := 2 + ELSIF id = "nostkchk" THEN num := 4 + ELSIF id = "ccall" THEN num := -10 + ELSIF id = "guarded" THEN num := 8 + ELSIF id = "noframe" THEN num := 16 + ELSIF id = "native" THEN num := -33 + ELSIF id = "bytecode" THEN num := -35 + END + END; + IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num) + ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num) + ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10 + ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8 + ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16 + ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num + ELSE err(225); flag := 0 + END + END GetProcSysFlag; + + PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (options * {sys386, sys68k, interface, com} # {}) THEN + IF (num = 1) OR (id = "nil") THEN + IF ~ODD(old) THEN flag := SHORT(old + 1) END + ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 2) END + ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 4) END + ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN + IF old <= 1 THEN flag := SHORT(old + 8) END + ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 16) END + END + END; + IF flag = 0 THEN err(225) END + END GetVarParSysFlag; + + PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 3) OR (id = "noalign") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END + ELSIF (num = 4) OR (id = "align2") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END + ELSIF (num = 5) OR (id = "align4") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END + ELSIF (num = 6) OR (id = "align8") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END + ELSIF (num = 7) OR (id = "union") THEN + IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END + ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = -11) OR (id = "jint") THEN + IF (java IN options) & (old = 0) THEN flag := -11 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetRecordSysFlag; + + PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = -12) OR (id = "jarr") THEN + IF (java IN options) & (old = 0) THEN flag := -12 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + END; + IF flag = 0 THEN err(225) END + END GetArraySysFlag; + + PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 2) OR (id = "handle") THEN + IF (sys68k IN options) & (old = 0) THEN flag := 2 END + ELSIF (num = 10) OR (id = "interface") THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetPointerSysFlag; + + PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10 + ELSE err(225); flag := 0 + END + END GetProcTypSysFlag; + + PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *) + IF flag = 0 THEN flag := baseFlag + ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *) + ELSIF flag # baseFlag THEN err(225); flag := 0 + END + ELSIF (baseFlag # 10) & (flag = 10) THEN err(225) + END + END PropagateRecordSysFlag; + + PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = 10 THEN (* pointer to interface is interface *) + IF flag = 0 THEN flag := 10 + ELSIF flag # 10 THEN err(225); flag := 0 + END + ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *) + IF flag # 0 THEN err(225) END; + flag := -11 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateRecPtrSysFlag; + + PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = -12 THEN (* pointer to java array is java array *) + IF flag # 0 THEN err(225) END; + flag := -12 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateArrPtrSysFlag; + + + (* utf8 strings *) + + PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER); + BEGIN + ASSERT((val >= 0) & (val < 65536)); + IF val < 128 THEN + str[idx] := SHORT(CHR(val)); INC(idx) + ELSIF val < 2048 THEN + str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + ELSE + str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); + str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + END + END PutUtf8; + + PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER); + VAR ch: SHORTCHAR; + BEGIN + ch := str[idx]; INC(idx); + IF ch < 80X THEN + val := ORD(ch) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + ELSE + val := ORD(ch) - 224; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + END + END GetUtf8; + + PROCEDURE Mark* (n, pos: INTEGER); + BEGIN + IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN + noerr := FALSE; + IF pos < 0 THEN pos := 0 END; + IF (pos < lastpos) OR (lastpos + 9 < pos) THEN + lastpos := pos; + IF errors < maxErrors THEN + errNo[errors] := n; errPos[errors] := pos + END; + INC(errors) + END; + IF trap IN options THEN HALT(100) END; + ELSIF (n <= -700) & (errors < maxErrors) THEN + errNo[errors] := -n; errPos[errors] := pos; INC(errors) + END + END Mark; + + PROCEDURE err* (n: INTEGER); + BEGIN + Mark(n, errpos) + END err; + + (* fingerprinting *) + + PROCEDURE InitCrcTab; + (* CRC32, high bit first, pre & post inverted *) + CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *) + VAR x, c, i: INTEGER; + BEGIN + x := 0; + WHILE x < 256 DO + c := x * 1000000H; i := 0; + WHILE i < 8 DO + IF c < 0 THEN c := ORD(BITS(c * 2) / poly) + ELSE c := c * 2 + END; + INC(i) + END; + crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255)); + INC(x) + END + END InitCrcTab; + + PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER); + VAR c: INTEGER; + BEGIN +(* + fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *) +*) + (* CRC32, high bit first, pre & post inverted *) + c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256])); + fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256])); + END FPrint; + + PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET); + BEGIN FPrint(fp, ORD(set)) + END FPrintSet; + + PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL); + BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real)) + END FPrintReal; + + PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL); + VAR l, h: INTEGER; + BEGIN + FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr)) + END FPrintLReal; + + PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *) + BEGIN + (* same as FPrint, 8 bit only *) + fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256])) + END ChkSum; + + + + (* compact format *) + + PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER); + BEGIN + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))) + END WriteLInt; + + PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; x: INTEGER; + BEGIN + r.ReadByte(b); x := b MOD 256; + ChkSum(checksum, b); + r.ReadByte(b); x := x + 100H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); x := x + 10000H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); i := x + 1000000H * b; + ChkSum(checksum, b) + END ReadLInt; + + PROCEDURE WriteNum (w: Files.Writer; i: INTEGER); + BEGIN (* old format of Oberon *) + WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END; + ChkSum(checksum, i MOD 128); + w.WriteByte(SHORT(SHORT(i MOD 128))) + END WriteNum; + + PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; r.ReadByte(b); + IF ~r.eof THEN ChkSum(checksum, b) END; + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y; + END ReadNum; + + PROCEDURE WriteNumSet (w: Files.Writer; x: SET); + BEGIN + WriteNum(w, ORD(x)) + END WriteNumSet; + + PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET); + VAR i: INTEGER; + BEGIN + ReadNum(r, i); x := BITS(i) + END ReadNumSet; + + PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL); + BEGIN + WriteLInt(w, SYSTEM.VAL(INTEGER, x)) + END WriteReal; + + PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL); + VAR i: INTEGER; + BEGIN + ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i) + END ReadReal; + + PROCEDURE WriteLReal (w: Files.Writer; x: REAL); + BEGIN + WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x)) + END WriteLReal; + + PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL); + VAR h, l: INTEGER; + BEGIN + ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h) + END ReadLReal; + + + (* read symbol file *) + + PROCEDURE SymRCh* (VAR ch: SHORTCHAR); + VAR b: BYTE; + BEGIN + inSym.ReadByte(b); ch := SHORT(CHR(b)); + ChkSum(checksum, b) + END SymRCh; + + PROCEDURE SymRInt* (): INTEGER; + VAR k: INTEGER; + BEGIN + ReadNum(inSym, k); RETURN k + END SymRInt; + + PROCEDURE SymRSet* (VAR s: SET); + BEGIN + ReadNumSet(inSym, s) + END SymRSet; + + PROCEDURE SymRReal* (VAR r: SHORTREAL); + BEGIN + ReadReal(inSym, r) + END SymRReal; + + PROCEDURE SymRLReal* (VAR lr: REAL); + BEGIN + ReadLReal(inSym, lr) + END SymRLReal; + + PROCEDURE eofSF* (): BOOLEAN; + BEGIN + RETURN inSym.eof + END eofSF; + + PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN); + VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name; + BEGIN + done := FALSE; + IF modName = "@file" THEN + oldSymFile := file + ELSE + name := modName$; Kernel.SplitName(name, dir, name); + Kernel.MakeFileName(name, Kernel.symType); + loc := Files.dir.This(dir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared); + IF (oldSymFile = NIL) & (dir = "") THEN + loc := Files.dir.This(SYSdir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared) + END + END; + IF oldSymFile # NIL THEN + inSym := oldSymFile.NewReader(inSym); + IF inSym # NIL THEN + ReadLInt(inSym, tag); + IF tag = SFtag THEN done := TRUE ELSE err(151) END + END + END + END OldSym; + + PROCEDURE CloseOldSym*; + BEGIN + IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END + END CloseOldSym; + + + (* write symbol file *) + + PROCEDURE SymWCh* (ch: SHORTCHAR); + BEGIN + ChkSum(checksum, ORD(ch)); + outSym.WriteByte(SHORT(ORD(ch))) + END SymWCh; + + PROCEDURE SymWInt* (i: INTEGER); + BEGIN + WriteNum(outSym, i) + END SymWInt; + + PROCEDURE SymWSet* (s: SET); + BEGIN + WriteNumSet(outSym, s) + END SymWSet; + + PROCEDURE SymWReal* (VAR r: SHORTREAL); + BEGIN + WriteReal(outSym, r) + END SymWReal; + + PROCEDURE SymWLReal* (VAR r: REAL); + BEGIN + WriteLReal(outSym, r) + END SymWLReal; + + PROCEDURE SymReset*; + BEGIN + outSym.SetPos(4) + END SymReset; + + PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(symDir); + symFile := Files.dir.New(loc, Files.ask); + IF symFile # NIL THEN + outSym := symFile.NewWriter(NIL); + WriteLInt(outSym, SFtag) + ELSE + err(153) + END + END NewSym; + + PROCEDURE RegisterNewSym*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF symFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.symType); + symFile.Register(name, Kernel.symType, Files.ask, res); + symFile := NIL + END + END RegisterNewSym; + + PROCEDURE DeleteNewSym*; + BEGIN + IF symFile # NIL THEN symFile.Close; symFile := NIL END + END DeleteNewSym; + + + (* write object file *) + + PROCEDURE ObjW* (ch: SHORTCHAR); + BEGIN + outObj.WriteByte(SHORT(ORD(ch))) + END ObjW; + + PROCEDURE ObjWNum* (i: INTEGER); + BEGIN + WriteNum(outObj, i) + END ObjWNum; + + PROCEDURE ObjWInt (i: SHORTINT); + BEGIN + outObj.WriteByte(SHORT(SHORT(i MOD 256))); + outObj.WriteByte(SHORT(SHORT(i DIV 256))) + END ObjWInt; + + PROCEDURE ObjWLInt* (i: INTEGER); + BEGIN + ObjWInt(SHORT(i MOD 65536)); + ObjWInt(SHORT(i DIV 65536)) + END ObjWLInt; + + PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER); + TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE; + VAR p: P; + BEGIN + p := SYSTEM.VAL(P, SYSTEM.ADR(bytes)); + outObj.WriteBytes(p^, 0, n) + END ObjWBytes; + + PROCEDURE ObjLen* (): INTEGER; + BEGIN + RETURN outObj.Pos() + END ObjLen; + + PROCEDURE ObjSet* (pos: INTEGER); + BEGIN + outObj.SetPos(pos) + END ObjSet; + + PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + errpos := 0; + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(codeDir); + objFile := Files.dir.New(loc, Files.ask); + IF objFile # NIL THEN + outObj := objFile.NewWriter(NIL); + WriteLInt(outObj, OFtag) + ELSE + err(153) + END + END NewObj; + + PROCEDURE RegisterObj*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF objFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.objType); + objFile.Register(name, Kernel.objType, Files.ask, res); + objFile := NIL; outObj := NIL + END + END RegisterObj; + + PROCEDURE DeleteObj*; + BEGIN + IF objFile # NIL THEN objFile.Close; objFile := NIL END + END DeleteObj; + + + PROCEDURE InitHost; + VAR test: SHORTINT; lo: SHORTCHAR; + BEGIN + test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X; + InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat); + MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat); + MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat); + MinReal64 := Compound(MinReal64PatL, MinReal64PatH); + MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH) + END InitHost; + +BEGIN + InitCrcTab; + InitHost +END Dev0CPM. diff --git a/Trurl-based/Dev0/Mod/CPP.odc b/Trurl-based/Dev0/Mod/CPP.odc new file mode 100644 index 0000000..0cd6ae1 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPP.odc differ diff --git a/Trurl-based/Dev0/Mod/CPP.txt b/Trurl-based/Dev0/Mod/CPP.txt new file mode 100644 index 0000000..bd729fb --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPP.txt @@ -0,0 +1,1662 @@ +MODULE Dev0CPP; + + (* THIS IS TEXT COPY OF CPP.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT + DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPB := Dev0CPB, DevCPS := Dev0CPS; + + CONST + anchorVarPar = TRUE; + + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + + (* node subclasses *) + super = 1; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13; + + + TYPE + Elem = POINTER TO RECORD + next: Elem; + struct: DevCPT.Struct; + obj, base: DevCPT.Object; + pos: INTEGER; + name: DevCPT.String + END; + + + VAR + sym, level: BYTE; + LoopLevel: SHORTINT; + TDinit, lastTDinit: DevCPT.Node; + userList: Elem; + recList: Elem; + hasReturn: BOOLEAN; + numUsafeVarPar, numFuncVarPar: INTEGER; + + + PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String); + PROCEDURE^ Expression(VAR x: DevCPT.Node); + PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node); + + (* forward type handling *) + + PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN; + BEGIN + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp) + END IncompleteType; + + PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String); + VAR u: Elem; + BEGIN + IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END; + IF name # NIL THEN + NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name; + u.next := userList; userList := u + END + END SetType; + + PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER); + BEGIN + typ.pvused := TRUE; + IF typ.comp = DynArr THEN + IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END + ELSIF typ.comp = Record THEN + IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN + DevCPM.Mark(193, pos); typ := DevCPT.undftyp + END + END + END CheckAlloc; + + PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER); + VAR fld: DevCPT.Object; + BEGIN + IF outer = inner THEN DevCPM.Mark(58, pos) + ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos) + ELSIF inner.comp = Record THEN + fld := inner.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + CheckRecursiveType(outer, fld.typ, pos); + fld := fld.link + END; + IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END + END + END CheckRecursiveType; + + PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + (* fix forward reference *) + VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT; + BEGIN + IF obj # NIL THEN + IF obj.mode = Var THEN (* variable type *) + IF struct # NIL THEN (* receiver type *) + IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END; + ELSE CheckAlloc(typ, obj.mnolev > level, pos) (* TRUE for parameters *) + END + ELSIF obj.mode = VarPar THEN (* varpar type *) + IF struct # NIL THEN (* varpar receiver type *) + IF typ # struct THEN DevCPM.Mark(180, pos) END + END + ELSIF obj.mode = Fld THEN (* field type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF obj.mode = TProc THEN (* proc return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END + ELSIF obj.mode = Typ THEN (* alias type *) + IF typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + t := DevCPT.NewStr(typ.form, Basic); i := t.ref; + t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0; + t.BaseTyp := typ; typ := t + END; + IF obj.vis # internal THEN + IF typ.comp = Record THEN typ.exp := TRUE + ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE + END + END + ELSE HALT(100) + END; + obj.typ := typ + ELSE + IF struct.form = Pointer THEN (* pointer base type *) + IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag) + ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag) + ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos) + END; + struct.untagged := struct.sysflag > 0; + IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END; + ELSIF struct.comp = Array THEN (* array base type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = DynArr THEN (* array base type *) + CheckAlloc(typ, TRUE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = Record THEN (* record base type *) + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1)); + DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag); + IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos) + ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos) + ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos) + END; + f := struct.link; + WHILE f # NIL DO (* check for field name conflicts *) + DevCPT.FindField(f.name, typ, bf); + IF bf # NIL THEN DevCPM.Mark(1, pos) END; + f := f.link + END; + CheckRecursiveType(struct, typ, pos); + struct.untagged := struct.sysflag > 0; + ELSIF struct.form = ProcTyp THEN (* proc type return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END; + ELSE HALT(100) + END; + struct.BaseTyp := typ + END + END FixType; + + PROCEDURE CheckForwardTypes; + VAR u, next: Elem; progress: BOOLEAN; + BEGIN + u := userList; userList := NIL; + WHILE u # NIL DO + next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base); + IF u.base = NIL THEN DevCPM.Mark(0, u.pos) + ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos) + ELSE u.next := userList; userList := u (* reinsert *) + END; + u := next + END; + REPEAT (* iteration for multy level alias *) + u := userList; userList := NIL; progress := FALSE; + WHILE u # NIL DO + next := u.next; + IF IncompleteType(u.base.typ) THEN + u.next := userList; userList := u (* reinsert *) + ELSE + progress := TRUE; + FixType(u.struct, u.obj, u.base.typ, u.pos) + END; + u := next + END + UNTIL (userList = NIL) OR ~progress; + u := userList; (* remaining type relations are cyclic *) + WHILE u # NIL DO + IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END; + u := u.next + END; + END CheckForwardTypes; + + PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + VAR obj: DevCPT.Object; + BEGIN + IF m # NIL THEN + IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN + DevCPT.FindField(m.name^, typ, obj); + IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN + DevCPM.Mark(192, pos); + DevCPM.errorMes := DevCPM.errorMes + " " + m.name^ + " not implemented"; + IF typ.strobj # NIL THEN + DevCPM.errorMes := DevCPM.errorMes+ " in " + typ.strobj.name^ + END + END + END; + CheckUnimpl(m.left, typ, pos); + CheckUnimpl(m.right, typ, pos) + END + END CheckUnimpl; + + PROCEDURE CheckRecords (rec: Elem); + VAR b: DevCPT.Struct; + BEGIN + WHILE rec # NIL DO (* check for unimplemented methods in base type *) + b := rec.struct.BaseTyp; + WHILE (b # NIL) & (b # DevCPT.undftyp) DO + CheckUnimpl(b.link, rec.struct, rec.pos); + b := b.BaseTyp + END; + rec := rec.next + END + END CheckRecords; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE CheckSym(s: SHORTINT); + BEGIN + IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END + END CheckSym; + + PROCEDURE qualident(VAR id: DevCPT.Object); + VAR obj: DevCPT.Object; lev: BYTE; + BEGIN (*sym = ident*) + DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym); + IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym) + ELSE err(ident); obj := NIL + END + END ; + IF obj = NIL THEN err(0); + obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0 + ELSE lev := obj.mnolev; + IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN + obj.leaf := FALSE; + IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END (* !!! *) + END + END ; + id := obj + END qualident; + + PROCEDURE ConstExpression(VAR x: DevCPT.Node); + BEGIN Expression(x); + IF x.class # Nconst THEN + err(50); x := DevCPB.NewIntConst(1) + END + END ConstExpression; + + PROCEDURE CheckMark(obj: DevCPT.Object); (* !!! *) + VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String; + BEGIN DevCPS.Get(sym); + IF (sym = times) OR (sym = minus) THEN + IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ; + IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ; + DevCPS.Get(sym) + ELSE obj.vis := internal + END; + IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); n := 0; + IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + obj.library := obj.entry; obj.entry := NIL; + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); + ELSE err(string) + END + END; + WHILE sym = comma DO + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n) + ELSE err(235) + END; + DevCPS.Get(sym) + ELSE err(string) + END + END; + IF n > 0 THEN + NEW(obj.modifiers, n); + WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END + END + ELSE err(string) + END; + CheckSym(rbrak); + IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END + END + END CheckMark; + + PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT; + GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT)); + VAR x: DevCPT.Object; i: SHORTINT; + BEGIN + sysflag := 0; + IF sym = lbrak THEN + DevCPS.Get(sym); + WHILE (sym = number) OR (sym = ident) OR (sym = string) DO + IF sym = number THEN + IF DevCPS.numtyp = integer THEN + i := SHORT(DevCPS.intval); GetSF("", i, sysflag) + ELSE err(225) + END + ELSIF sym = ident THEN + DevCPT.Find(DevCPS.name, x); + IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN + i := SHORT(x.conval.intval); GetSF("", i, sysflag) + ELSE + GetSF(DevCPS.name, 0, sysflag) + END + ELSE + GetSF(DevCPS.str^, 0, sysflag) + END; + DevCPS.Get(sym); + IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END + END; + CheckSym(rbrak) + END + END CheckSysFlag; + + PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct); + VAR obj: DevCPT.Object; tname: DevCPT.String; + BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar; + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar (* ??? *) + ELSE mode := Var + END ; + name := DevCPS.name; CheckSym(ident); CheckSym(colon); + IF sym # ident THEN err(ident) END; + Type(typ, tname); + IF tname = NIL THEN + IF typ.form = Pointer THEN rec := typ.BaseTyp ELSE rec := typ END; + IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR + (mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END; + IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END + ELSE err(0) + END; + CheckSym(rparen); + IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END + END Receiver; + + PROCEDURE FormalParameters( + VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String + ); + VAR mode, vis: BYTE; sys: SHORTINT; + par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct; + BEGIN + first := NIL; last := firstPar; + newPar := NIL; iidPar := NIL; + IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN + LOOP + sys := 0; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar + ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar + ELSE mode := Var + END ; + IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END; + IF ODD(sys DIV inBit) THEN vis := inPar + ELSIF ODD(sys DIV outBit) THEN vis := outPar + END; + IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225) + ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225) + END; + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym); + par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys); + IF first = NIL THEN first := par END ; + IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ; + last := par + ELSE err(ident) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSIF sym = var THEN err(comma); DevCPS.Get(sym) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END; + IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177) + END; + (* typ.pbused is set when parameter type name is parsed *) + WHILE first # NIL DO + SetType (NIL, first, typ, name); + IF DevCPM.com IN DevCPM.options THEN + IF ODD(sys DIV newBit) THEN + IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END; + newPar := first + ELSIF ODD(sys DIV iidBit) THEN + IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END; + iidPar := first + END + END; + first := first.link + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END + END; + CheckSym(rparen); + IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END; + name := NIL; + IF sym = colon THEN + DevCPS.Get(sym); + Type(resTyp, name); + IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END + ELSE resTyp := DevCPT.notyp + END + END FormalParameters; + + PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct); + VAR o, bo: DevCPT.Object; + BEGIN + IF base # NIL THEN + IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END; + IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis) + OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END; + o := proc.link; bo := base.link; + WHILE (o # NIL) & (bo # NIL) DO + IF (bo.sysflag # 0) & (o.sysflag = 0) THEN (* propagate sysflags *) + o.sysflag := bo.sysflag + END; + o := o.link; bo := bo.link + END; + DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE); + IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END; + IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END; + INCL(proc.conval.setval, isRedef) + END; + END CheckOverwrite; + + PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct); (* read method attributes *) + VAR attr, battr: SET; o: DevCPT.Object; + BEGIN + attr := {}; + IF sym = comma THEN (* read attributes *) + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.Find(DevCPS.name, o); + IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN + IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END; + DevCPS.Get(sym); + IF sym = comma THEN + DevCPS.Get(sym); + IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END + ELSE o := NIL + END + END; + IF o # NIL THEN + IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178) + ELSE INCL(attr, o.adr) + END; + DevCPS.Get(sym) + END + ELSE err(ident) + END + END; + IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr) + ELSIF (base # NIL) & (newAttr IN attr) THEN err(186) + END; + IF absAttr IN attr THEN + IF owner.attribute # absAttr THEN err(190) END; + IF (proc.vis = internal) & owner.exp THEN err(179) END + END; + IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN + IF (empAttr IN attr) & (newAttr IN attr) THEN err(187) +(* + ELSIF extAttr IN attr THEN err(188) +*) + END + END; + IF base # NIL THEN + battr := base.conval.setval; + IF empAttr IN battr THEN + IF absAttr IN attr THEN err(189) END + ELSIF ~(absAttr IN battr) THEN + IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END + END + END; + IF empAttr IN attr THEN + IF proc.typ # DevCPT.notyp THEN err(195) + ELSE + o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END; + IF o # NIL THEN err(195) END + END + END; + IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END; + proc.conval.setval := attr + END GetAttributes; + + PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object); + VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL; + CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag); + IF attr # NIL THEN + IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr)) + ELSE err(178) + END + END; + IF typ.sysflag = interface THEN + IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END; + IF typ.attribute # absAttr THEN err(163) END; + IF sym # lparen THEN err(160) END + END; + IF sym = lparen THEN + DevCPS.Get(sym); (*record extension*) + IF sym = ident THEN + Type(ftyp, name); + IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END; + SetType(typ, NIL, ftyp, name); + IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN + ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1)); + DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag); + IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181) + ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191) + ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197) + END + ELSIF ftyp # DevCPT.undftyp THEN err(53) + END + ELSE err(ident) + END ; + IF typ.attribute # absAttr THEN (* save typ for unimplemented method check *) + NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r + END; + CheckSym(rparen) + END; +(* + DevCPT.OpenScope(0, NIL); +*) + first := NIL; last := NIL; + LOOP + IF sym = ident THEN + LOOP + IF sym = ident THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN + DevCPT.FindBaseField(DevCPS.name, typ, fld); + IF fld # NIL THEN err(1) END + END ; + DevCPT.InsertField(DevCPS.name, typ, fld); + fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp; + CheckMark(fld); + IF first = NIL THEN first := fld END ; + IF last = NIL THEN typ.link := fld ELSE last.link := fld END ; + last := fld + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(ftyp, name); + CheckAlloc(ftyp, FALSE, DevCPM.errpos); + WHILE first # NIL DO + SetType(typ, first, ftyp, name); first := first.link + END; + IF typ.sysflag = interface THEN err(161) END + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END; +(* + IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END; + typ.link := DevCPT.topScope.right; DevCPT.CloseScope; +*) + typ.untagged := typ.sysflag > 0; + DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) + END RecordType; + + PROCEDURE ArrayType(VAR typ: DevCPT.Struct); + VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String; + BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag); + IF sym = of THEN (*dynamic array*) + typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag; + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END + ELSE + typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x); + IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval; + IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END + ELSE err(42); n := 1 + END ; + typ.n := n; + IF sym = of THEN + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos) + ELSIF sym = comma THEN + DevCPS.Get(sym); + IF sym # of THEN ArrayType(typ.BaseTyp) END + ELSE err(35) + END + END; + typ.untagged := typ.sysflag > 0 + END ArrayType; + + PROCEDURE PointerType(VAR typ: DevCPT.Struct); + VAR id: DevCPT.Object; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag); + CheckSym(to); + Type(typ.BaseTyp, name); + SetType(typ, NIL, typ.BaseTyp, name); + IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN + typ.BaseTyp := DevCPT.undftyp; err(57) + END; + IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + END; + typ.untagged := typ.sysflag > 0 + END PointerType; + + PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String); (* name # NIL => forward reference *) + VAR id: DevCPT.Object; tname: DevCPT.String; + BEGIN + typ := DevCPT.undftyp; name := NIL; + IF sym < lparen THEN err(12); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + DevCPT.Find(DevCPS.name, id); + IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN (* forward type definition *) + name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym); + IF (id = NIL) & (sym = period) THEN (* missing module *) + err(0); DevCPS.Get(sym); name := NIL; + IF sym = ident THEN DevCPS.Get(sym) END + ELSIF sym = record THEN (* wrong attribute *) + err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL) + END + ELSE + qualident(id); + IF id.mode = Typ THEN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN + err(198) + END; + typ := id.typ + ELSIF id.mode = Attr THEN + IF sym = record THEN + DevCPS.Get(sym); RecordType(typ, id) + ELSE err(12) + END + ELSE err(52) + END + END + ELSIF sym = array THEN + DevCPS.Get(sym); ArrayType(typ) + ELSIF sym = record THEN + DevCPS.Get(sym); RecordType(typ, NIL) + ELSIF sym = pointer THEN + DevCPS.Get(sym); PointerType(typ) + ELSIF sym = procedure THEN + DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic); + CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag); + typ.untagged := typ.sysflag > 0; + IF sym = lparen THEN + DevCPS.Get(sym); DevCPT.OpenScope(level, NIL); + FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope + ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL + END + ELSE err(12) + END ; + LOOP + IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) + OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END; + err(15); IF sym = ident THEN EXIT END; + DevCPS.Get(sym) + END + END Type; + + PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node); + VAR apar, last, newPar, iidPar, n: DevCPT.Node; + BEGIN + aparlist := NIL; last := NIL; + IF sym # rparen THEN + newPar := NIL; iidPar := NIL; + LOOP Expression(apar); + IF fpar # NIL THEN + IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END; + DevCPB.Param(apar, fpar); + IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END; + DevCPB.Link(aparlist, last, apar); + IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar + ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar + END; + IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END; + IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options) + OR (DevCPM.allSysVal IN DevCPM.options) (* source output: avoid double evaluation *) + & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged + OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN + n := apar; + WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 0) THEN + IF n.left.class = Nguard THEN n := n.left END; + DevCPB.CheckVarParBuffering(n.left, pre, lastp) + END + END; + fpar := fpar.link + ELSE err(64) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END + END; + IF fpar # NIL THEN err(65) END + END ActualParameters; + + PROCEDURE selector(VAR x: DevCPT.Node); + VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name; + BEGIN + LOOP + IF sym = lbrak THEN DevCPS.Get(sym); + LOOP + IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ; + Expression(y); DevCPB.Index(x, y); + IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END + END ; + CheckSym(rbrak) + ELSIF sym = period THEN DevCPS.Get(sym); + IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym); + IF x.typ # NIL THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ; + IF x.typ.comp = Record THEN + typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj); + IF (obj # NIL) & (obj.mode = TProc) THEN + IF sym = arrow THEN (* super call *) DevCPS.Get(sym); + y := x.left; + IF y.class = Nderef THEN y := y.left END ; (* y = record variable *) + IF y.obj # NIL THEN + proc := DevCPT.topScope; (* find innermost scope which owner is a TProc *) + WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ; + IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75) + END ; + typ := y.obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END ; + DevCPT.FindBaseField(x.obj.name^, typ, p); + IF p # NIL THEN + x.subcl := super; x.typ := p.typ; (* correct result type *) + IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END; + IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END; + ELSE err(74) + END + ELSE err(75) + END + ELSE + proc := obj; + WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO + (* find base method *) + typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc); + END; + IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END; + END ; + IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END + END + ELSE err(53) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x) + ELSIF sym = dollar THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + DevCPS.Get(sym); DevCPB.StrDeref(x) + ELSIF sym = lparen THEN + IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ + ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp + ELSIF x.class = Nproc THEN EXIT (* standard procedure *) + ELSE typ := NIL + END; + IF typ # DevCPT.notyp THEN + DevCPS.Get(sym); + IF typ = NIL THEN (* type guard *) + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END + ELSE (* function call *) + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) + END; + ActualParameters(apar, fpar, pre, lastp); + DevCPB.Call(x, apar, fpar); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END; + CheckSym(rparen) + ELSE EXIT + END +(* + ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) & + ((x.obj = NIL) OR (x.obj.mode # TProc)) THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END ; + CheckSym(rparen) +*) + ELSE EXIT + END + END + END selector; + + PROCEDURE StandProcCall(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; m: BYTE; n: SHORTINT; + BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0; + IF sym = lparen THEN DevCPS.Get(sym); + IF sym # rparen THEN + LOOP + IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1 + ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2 + ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(rparen) + ELSE DevCPS.Get(sym) + END ; + DevCPB.StFct(x, m, n) + ELSE err(lparen) + END ; + IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END + END StandProcCall; + + PROCEDURE Element(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN Expression(x); + IF sym = upto THEN + DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y) + ELSE DevCPB.SetElem(x) + END + END Element; + + PROCEDURE Sets(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN + IF sym # rbrace THEN + Element(x); + LOOP + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END ; + Element(y); DevCPB.Op(plus, x, y) + END + ELSE x := DevCPB.EmptySet() + END ; + CheckSym(rbrace) + END Sets; + + PROCEDURE Factor(VAR x: DevCPT.Node); + VAR fpar, id: DevCPT.Object; apar: DevCPT.Node; + BEGIN + IF sym < not THEN err(13); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) +(* + ELSIF sym = lparen THEN + DevCPS.Get(sym); DevCPB.PrepCall(x, fpar); + ActualParameters(apar, fpar); + DevCPB.Call(x, apar, fpar); + CheckSym(rparen); + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END +*) + END + ELSIF sym = number THEN + CASE DevCPS.numtyp OF + char: + x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ; + IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END + | integer: x := DevCPB.NewIntConst(DevCPS.intval) + | int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval) + | real: x := DevCPB.NewRealConst(DevCPS.realval, NIL) + | real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ) + | real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ) + END ; + DevCPS.Get(sym) + ELSIF sym = string THEN + x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval); + DevCPS.Get(sym) + ELSIF sym = nil THEN + x := DevCPB.Nil(); DevCPS.Get(sym) + ELSIF sym = lparen THEN + DevCPS.Get(sym); Expression(x); CheckSym(rparen) + ELSIF sym = lbrak THEN + DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) + ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x) + ELSIF sym = not THEN + DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x) + ELSE err(13); DevCPS.Get(sym); x := NIL + END ; + IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END + END Factor; + + PROCEDURE Term(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; mulop: BYTE; + BEGIN Factor(x); + WHILE (times <= sym) & (sym <= and) DO + mulop := sym; DevCPS.Get(sym); + Factor(y); DevCPB.Op(mulop, x, y) + END + END Term; + + PROCEDURE SimpleExpression(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; addop: BYTE; + BEGIN + IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x) + ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x) + ELSE Term(x) + END ; + WHILE (plus <= sym) & (sym <= or) DO + addop := sym; DevCPS.Get(sym); Term(y); + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(x) + END; + IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(y) + END; + DevCPB.Op(addop, x, y) + END + END SimpleExpression; + + PROCEDURE Expression(VAR x: DevCPT.Node); + VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE; + BEGIN SimpleExpression(x); + IF (eql <= sym) & (sym <= geq) THEN + relation := sym; DevCPS.Get(sym); SimpleExpression(y); + pre := NIL; last := NIL; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(x) + END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(y) + END; + DevCPB.CheckBuffering(x, NIL, NIL, pre, last); + DevCPB.CheckBuffering(y, NIL, NIL, pre, last); + DevCPB.Op(relation, x, y); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END + ELSIF sym = in THEN + DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y) + ELSIF sym = is THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE) + ELSE err(52) + END + ELSE err(ident) + END + END + END Expression; + + PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node); + VAR proc, fwd: DevCPT.Object; + name: DevCPT.Name; + mode: BYTE; + forward: BOOLEAN; + sys: SHORTINT; + + PROCEDURE GetCode; + VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR; + BEGIN + n := 0; + IF sym = string THEN + NEW(ext, DevCPS.intval); + WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ; + ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym); + ELSE + LOOP + IF sym = number THEN c := DevCPS.intval; INC(n); + IF (c < 0) OR (c > 255) OR (n = 255) THEN + err(64); c := 1; n := 1 + END ; + DevCPS.Get(sym); s[n] := SHORT(CHR(c)) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = number THEN err(comma) + ELSE s[0] := SHORT(CHR(n)); EXIT + END + END; + NEW(ext, n + 1); i := 0; + WHILE i <= n DO ext[i] := s[i]; INC(i) END; + END; + proc.conval.ext := ext; + INCL(proc.conval.setval, hasBody) + END GetCode; + + PROCEDURE GetParams; + VAR name: DevCPT.String; + BEGIN + proc.mode := mode; proc.typ := DevCPT.notyp; + proc.sysflag := SHORT(sys); + proc.conval.setval := {}; + IF sym = lparen THEN + DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name); + IF name # NIL THEN err(0) END + END; + CheckForwardTypes; userList := NIL; + IF fwd # NIL THEN + DevCPB.CheckParameters(proc.link, fwd.link, TRUE); + IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ; + proc := fwd; DevCPT.topScope := proc.scope; + IF mode = IProc THEN proc.mode := IProc END + END + END GetParams; + + PROCEDURE Body; + VAR procdec, statseq: DevCPT.Node; c: INTEGER; + BEGIN + c := DevCPM.errpos; + INCL(proc.conval.setval, hasBody); + CheckSym(semicolon); Block(procdec, statseq); + DevCPB.Enter(procdec, statseq, proc); x := procdec; + x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # proc.name^ THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END + END Body; + + PROCEDURE TProcDecl; + VAR baseProc, o, bo: DevCPT.Object; + objTyp, recTyp: DevCPT.Struct; + objMode, objVis: BYTE; + objName: DevCPT.Name; + pnode: DevCPT.Node; + fwdAttr: SET; + BEGIN + DevCPS.Get(sym); mode := TProc; + IF level > 0 THEN err(73) END; + Receiver(objMode, objVis, objName, objTyp, recTyp); + IF sym = ident THEN + name := DevCPS.name; + DevCPT.FindField(name, recTyp, fwd); + DevCPT.FindBaseField(name, recTyp, baseProc); + IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ; + IF fwd = baseProc THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END; + fwdAttr := fwd.conval.setval + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.InsertField(name, recTyp, proc); + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF recTyp.strobj # NIL THEN (* preserve declaration order *) + o := recTyp.strobj.link; + IF o = NIL THEN recTyp.strobj.link := proc + ELSE + WHILE o.nlink # NIL DO o := o.nlink END; + o.nlink := proc + END + END + END; + INC(level); DevCPT.OpenScope(level, proc); + DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp; + ASSERT(DevCPT.topScope # NIL); + GetParams; (* may change proc := fwd !!! *) + ASSERT(DevCPT.topScope # NIL); + GetAttributes(proc, baseProc, recTyp); + IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END; + CheckOverwrite(proc, baseProc, recTyp); + IF ~forward THEN + IF empAttr IN proc.conval.setval THEN (* insert empty procedure *) + pnode := NIL; DevCPB.Enter(pnode, NIL, proc); + pnode.conval := DevCPT.NewConst(); + pnode.conval.intval := DevCPM.errpos; + pnode.conval.intval2 := DevCPM.errpos; + x := pnode; + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~(absAttr IN proc.conval.setval) THEN Body + END; + proc.adr := 0 + ELSE + proc.adr := DevCPM.errpos; + IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END + END; + DEC(level); DevCPT.CloseScope; + ELSE err(ident) + END; + END TProcDecl; + + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0; + IF (sym # ident) & (sym # lparen) THEN + CheckSysFlag(sys, DevCPM.GetProcSysFlag); + IF sys # 0 THEN + IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END + ELSE + IF sym = times THEN (* mode set later in DevCPB.CheckAssign *) + ELSIF sym = arrow THEN forward := TRUE + ELSE err(ident) + END; + DevCPS.Get(sym) + END + END ; + IF sym = lparen THEN TProcDecl + ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd); + name := DevCPS.name; + IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.Insert(name, proc); + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + END ; + IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ; + IF (mode # LProc) & (level > 0) THEN err(73) END ; + INC(level); DevCPT.OpenScope(level, proc); + proc.link := NIL; GetParams; (* may change proc := fwd !!! *) + IF mode = CProc THEN GetCode + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~forward THEN Body; proc.adr := 0 + ELSE proc.adr := DevCPM.errpos + END ; + DEC(level); DevCPT.CloseScope + ELSE err(ident) + END + END ProcedureDeclaration; + + PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER); + VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER; + + PROCEDURE Insert(VAR n: DevCPT.Node); (* build binary tree of label ranges *) (* !!! *) + BEGIN + IF n = NIL THEN + IF x.hint # 1 THEN n := x END + ELSIF yval < n.conval.intval THEN Insert(n.left) + ELSIF xval > n.conval.intval2 THEN Insert(n.right) + ELSE err(63) + END + END Insert; + + BEGIN lab := NIL; lastlab := NIL; + LOOP ConstExpression(x); f := x.typ.form; + IF f IN {Int8..Int32} + charSet THEN xval := x.conval.intval + ELSE err(61); xval := 1 + END ; + IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF sym = upto THEN + DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval; + IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF yval < xval THEN err(63); yval := xval END + ELSE yval := xval + END ; + x.conval.intval2 := yval; + IF xval < min THEN min := xval END; + IF yval > max THEN max := yval END; + IF lab = NIL THEN lab := x; Insert(root) + ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root) + ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval + ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval + ELSE + y := lab; + WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END; + IF y.link = NIL THEN y.link := x; Insert(root) + ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root) + ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval + ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval + END + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (sym = number) OR (sym = ident) THEN err(comma) + ELSE EXIT + END + END + END CaseLabelList; + + PROCEDURE StatSeq(VAR stat: DevCPT.Node); + VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN; + s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name; + + PROCEDURE CasePart(VAR x: DevCPT.Node); + VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node; + BEGIN + Expression(x); + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.form = Int64 THEN err(260) + ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125) + END ; + CheckSym(of); cases := NIL; lastcase := NIL; root := NIL; + low := MAX(INTEGER); high := MIN(INTEGER); + LOOP + IF sym < bar THEN + CaseLabelList(lab, root, x.typ.form, low, high); + CheckSym(colon); StatSeq(y); + DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab) + END ; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; + IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases); + cases.conval := DevCPT.NewConst(); + cases.conval.intval := low; cases.conval.intval2 := high; + IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END; + DevCPB.OptimizeCase(root); cases.link := root (* !!! *) + END CasePart; + + PROCEDURE SetPos(x: DevCPT.Node); + BEGIN + x.conval := DevCPT.NewConst(); x.conval.intval := pos + END SetPos; + + PROCEDURE CheckBool(VAR x: DevCPT.Node); + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE) + ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE) + END + END CheckBool; + + BEGIN stat := NIL; last := NIL; + LOOP x := NIL; + IF sym < ident THEN err(14); + REPEAT DevCPS.Get(sym) UNTIL sym >= ident + END ; + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF sym = becomes THEN + DevCPS.Get(sym); Expression(y); + IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END; + pre := NIL; lastp := NIL; + DevCPB.CheckBuffering(y, x, NIL, pre, lastp); + DevCPB.Assign(x, y); + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + ELSIF sym = eql THEN + err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y) + ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN + StandProcCall(x); + IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END; + IF (x # NIL) & (x.class = Nifelse) THEN (* error pos for ASSERT *) + SetPos(x.left); SetPos(x.left.right) + END + ELSIF x.class = Ncall THEN err(55) + ELSE + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END; + IF sym = lparen THEN + DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen) + ELSE apar := NIL; + IF fpar # NIL THEN err(65) END + END ; + DevCPB.Call(x, apar, fpar); + IF x.typ # DevCPT.notyp THEN err(55) END; + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END + ELSIF sym = if THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); + DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x; + WHILE sym = elsif DO + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); + DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y) + END ; + pos := DevCPM.startpos; + IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x); + ELSIF sym = case THEN + DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end) + ELSIF sym = while THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); + DevCPB.Construct(Nwhile, x, y); CheckSym(end) + ELSIF sym = repeat THEN + DevCPS.Get(sym); StatSeq(x); + IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y) + ELSE err(43) + END ; + DevCPB.Construct(Nrepeat, x, y) + ELSIF sym = for THEN + DevCPS.Get(sym); pos := DevCPM.startpos; + IF sym = ident THEN qualident(id); + IF ~(id.typ.form IN intSet) THEN err(68) END ; + CheckSym(becomes); Expression(y); + x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x); + CheckSym(to); pos := DevCPM.startpos; Expression(y); + IF y.class # Nconst THEN + DevCPB.GetTempVar("@for", x.left.typ, t); + z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z); + y := DevCPB.NewLeaf(t) + ELSE + DevCPB.CheckAssign(x.left.typ, y) + END ; + DevCPB.Link(stat, last, x); + p := DevCPM.startpos; + IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ; + x := DevCPB.NewLeaf(id); + IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y) + ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y) + ELSE err(63); DevCPB.Op(geq, x, y) + END ; + CheckSym(do); StatSeq(s); + y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y); + IF s = NIL THEN s := y + ELSE z := s; + WHILE z.link # NIL DO z := z.link END ; + z.link := y + END ; + CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p + ELSE err(ident) + END + ELSIF sym = loop THEN + DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); + DevCPB.Construct(Nloop, x, NIL); CheckSym(end) + ELSIF sym = with THEN + DevCPS.Get(sym); idtyp := NIL; x := NIL; + LOOP + IF sym < bar THEN + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); y := DevCPB.NewLeaf(id); + IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN + err(-302) (* warning 302 *) + END ; + CheckSym(colon); + IF sym = ident THEN qualident(t); + IF t.mode = Typ THEN + IF id # NIL THEN + idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ; + IF id.ptyp = NIL THEN id.ptyp := idtyp END + ELSE err(130) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSE err(ident) + END ; + CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y); + IF idtyp # NIL THEN + IF id.ptyp = idtyp THEN id.ptyp := NIL END; + id.typ := idtyp; idtyp := NIL + END ; + IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END + END; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; pos := DevCPM.startpos; + IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ; + DevCPB.Construct(Nwith, x, s); CheckSym(end); + IF e THEN x.subcl := 1 END + ELSIF sym = exit THEN + DevCPS.Get(sym); + IF LoopLevel = 0 THEN err(46) END ; + DevCPB.Construct(Nexit, x, NIL) + ELSIF sym = return THEN DevCPS.Get(sym); + IF sym < semicolon THEN Expression(x) END ; + IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link) + ELSE (* not standard Oberon *) DevCPB.Return(x, NIL) + END; + hasReturn := TRUE + END ; + IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + ELSE EXIT + END + END + END StatSeq; + + PROCEDURE Block(VAR procdec, statseq: DevCPT.Node); + VAR typ: DevCPT.Struct; + obj, first, last, o: DevCPT.Object; + x, lastdec: DevCPT.Node; + i: SHORTINT; + rname: DevCPT.Name; + name: DevCPT.String; + rec: Elem; + + BEGIN + IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END; + first := NIL; last := NIL; userList := NIL; recList := NIL; + LOOP + IF sym = const THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Con; CheckMark(obj); + obj.typ := DevCPT.int8typ; obj.mode := Var; (* Var to avoid recursive definition *) + IF sym = eql THEN + DevCPS.Get(sym); ConstExpression(x) + ELSIF sym = becomes THEN + err(eql); DevCPS.Get(sym); ConstExpression(x) + ELSE err(eql); x := DevCPB.NewIntConst(1) + END ; + obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *) + CheckSym(semicolon) + END + END ; + IF sym = type THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp; + CheckMark(obj); obj.mode := -1; + IF sym # eql THEN err(eql) END; + IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN + DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name); + END; + obj.mode := Typ; + IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref; + typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos; + typ.BaseTyp := obj.typ; obj.typ := typ; + END; + IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ; + IF obj.typ.form = Pointer THEN (* !!! *) + typ := obj.typ.BaseTyp; + IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN + (* pointer to unnamed record: name record as "pointerName^" *) + rname := obj.name^$; i := 0; + WHILE rname[i] # 0X DO INC(i) END; + rname[i] := "^"; rname[i+1] := 0X; + DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o + END + END; + IF obj.vis # internal THEN + typ := obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF typ.comp = Record THEN typ.exp := TRUE END + END; + CheckSym(semicolon) + END + END ; + IF sym = var THEN + DevCPS.Get(sym); + WHILE sym = ident DO + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp; + CheckMark(obj); + IF first = NIL THEN first := obj END ; + IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ; + last := obj + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + CheckAlloc(typ, FALSE, DevCPM.errpos); + WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ; + CheckSym(semicolon) + END + END ; + IF (sym < const) OR (sym > var) THEN EXIT END ; + END ; + CheckForwardTypes; + userList := NIL; rec := recList; recList := NIL; + DevCPT.topScope.adr := DevCPM.errpos; + procdec := NIL; lastdec := NIL; + IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END; + WHILE sym = procedure DO + DevCPS.Get(sym); ProcedureDeclaration(x); + IF x # NIL THEN + IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ; + lastdec := x + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END; + hasReturn := FALSE; + IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END; + IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq) + ELSE statseq := NIL + END ; + IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp) + & ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END; + IF (level = 0) & (TDinit # NIL) THEN + lastTDinit.link := statseq; statseq := TDinit + END + END Block; + + PROCEDURE Module*(VAR prog: DevCPT.Node); + VAR impName, aliasName: DevCPT.Name; + procdec, statseq: DevCPT.Node; + c, sf: INTEGER; done: BOOLEAN; + BEGIN + DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym); + IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ; + IF sym = ident THEN + DevCPT.Open(DevCPS.name); DevCPS.Get(sym); + DevCPT.libName := ""; + IF sym = lbrak THEN + INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym); + IF sym = eql THEN DevCPS.Get(sym) + ELSE INCL(DevCPM.options, DevCPM.noCode) + END; + IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym) + ELSE err(string) + END; + CheckSym(rbrak) + END; + CheckSym(semicolon); + IF sym = import THEN DevCPS.Get(sym); + LOOP + IF sym = ident THEN + aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym); + IF sym = becomes THEN DevCPS.Get(sym); + IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END + END ; + DevCPT.Import(aliasName, impName, done) + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos; + Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec; + prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos; + IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END; + prog.conval.realval := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # DevCPT.SelfName THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END; + IF sym # period THEN err(period) END + END + ELSE err(ident) + END ; + TDinit := NIL; lastTDinit := NIL; + DevCPS.str := NIL + END Module; + +END Dev0CPP. diff --git a/Trurl-based/Dev0/Mod/CPS.odc b/Trurl-based/Dev0/Mod/CPS.odc new file mode 100644 index 0000000..8548317 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPS.odc differ diff --git a/Trurl-based/Dev0/Mod/CPS.txt b/Trurl-based/Dev0/Mod/CPS.txt new file mode 100644 index 0000000..e989a83 --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPS.txt @@ -0,0 +1,379 @@ +MODULE Dev0CPS; + + (* THIS IS TEXT COPY OF CPS.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, Math, DevCPM := Dev0CPM, DevCPT := Dev0CPT; + + CONST + MaxIdLen = 256; + + TYPE +(* + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; +*) + + (* name, str, numtyp, intval, realval, realval are implicit results of Get *) + + VAR + name*: DevCPT.Name; + str*: DevCPT.String; + lstr*: POINTER TO ARRAY OF CHAR; + numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *) + intval*: INTEGER; (* integer value or string length (incl. 0X) *) + realval*: REAL; + + + CONST + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + VAR + ch: SHORTCHAR; (*current character*) + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE Str(VAR sym: BYTE); + VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN; + s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR; + BEGIN i := 0; och := ch; long := FALSE; + LOOP DevCPM.GetL(lch); + IF lch = och THEN EXIT END ; + IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END; + IF lch > 0FFX THEN long := TRUE END; + IF i < LEN(s) - 1 THEN s[i] := lch + ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch + ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch + ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch + END; + INC(i) + END ; + IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0]) + ELSE + sym := string; numtyp := 0; intval := i + 1; NEW(str, intval); + IF long THEN + IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$ + ELSE lstr[i] := 0X + END; + str^ := SHORT(lstr$) + ELSE + IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$); + ELSE lstr[i] := 0X; str^ := SHORT(lstr$) + END; + lstr := NIL + END + END; + DevCPM.Get(ch) + END Str; + + PROCEDURE Identifier(VAR sym: BYTE); + VAR i: SHORTINT; + BEGIN i := 0; + REPEAT + name[i] := ch; INC(i); DevCPM.Get(ch) + UNTIL (ch < "0") + OR ("9" < ch) & (CAP(ch) < "A") + OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À") + OR (ch = "×") + OR (ch = "÷") + OR (i = MaxIdLen); + IF i = MaxIdLen THEN err(240); DEC(i) END ; + name[i] := 0X; sym := ident + END Identifier; + + PROCEDURE Number; + VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL; + dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER; + + PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT; + BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *) + IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0")) + ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10) + ELSE err(2); RETURN 0 + END + END Ord; + + BEGIN (* ("0" <= ch) & (ch <= "9") *) + i := 0; m := 0; n := 0; d := 0; + LOOP (* read mantissa *) + IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN + IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *) + IF n < LEN(dig) THEN dig[n] := ch; INC(n) END; + INC(m) + END; + DevCPM.Get(ch); INC(i) + ELSIF ch = "." THEN DevCPM.Get(ch); + IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT + ELSIF d = 0 THEN (* i > 0 *) d := i + ELSE err(2) + END + ELSE EXIT + END + END; (* 0 <= n <= m <= i, 0 <= d <= i *) + IF d = 0 THEN (* integer *) realval := 0; numtyp := integer; + IF n = m THEN intval := 0; i := 0; + IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char; + IF n <= 4 THEN + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END + ELSE err(203) + END + ELSIF (ch = "H") OR (ch = "S") THEN (* hex 32bit *) + tch := ch; DevCPM.Get(ch); + IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN (* old syntax: hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF n <= 8 THEN + IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END; + IF tch = "S" THEN (* 32 bit hex float *) + r := SYSTEM.VAL(SHORTREAL, intval); + realval := r; intval := 0; numtyp := real32 + END + ELSE err(203) + END + ELSIF ch = "L" THEN (* hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF ch = "R" THEN (* hex float 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END; + a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END; + realval := SYSTEM.VAL(REAL, arr); + intval := 0; numtyp := real64 + ELSE err(203) + END + ELSE (* decimal *) + WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); + a := (MAX(INTEGER) - d) DIV 10; + IF intval > a THEN + a := (intval - a + 65535) DIV 65536 * 65536; + realval := realval + a; intval := intval - a + END; + realval := realval * 10; intval := intval * 10 + d + END; + IF realval = 0 THEN numtyp := integer + ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64 (* 2^63 *) + ELSE intval := 0; err(203) + END + END + ELSE err(203) + END + ELSE (* fraction *) + f := 0; g := 0; e := 0; j := 0; expCh := "E"; + WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END; (* !!! *) + WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END; + IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN + expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE; + IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch) + ELSIF ch = "+" THEN DevCPM.Get(ch) + END; + IF ("0" <= ch) & (ch <= "9") THEN + REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch); + IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n) + ELSE err(203) + END + UNTIL (ch < "0") OR ("9" < ch); + IF neg THEN e := -e END + ELSE err(2) + END + END; + DEC(e, i-d-m); (* decimal point shift *) + IF e < -308 - 16 THEN + realval := 0.0 + ELSIF e < -308 + 14 THEN + realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15 + ELSIF e < j THEN + realval := (f + g) / Math.IntPower(10, j-e) (* Ten(j-e) *) + ELSIF e <= 308 THEN + realval := (f + g) * Math.IntPower(10, e-j) (* Ten(e-j) *) + ELSIF e = 308 + 1 THEN + realval := (f + g) * (Math.IntPower(10, e-j) / 16); + IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16 + ELSE err(203) + END + ELSE err(203) + END; + numtyp := real + END + END Number; + + PROCEDURE Get*(VAR sym: BYTE); + VAR s: BYTE; old: INTEGER; + + PROCEDURE Comment; (* do not read after end of file *) + BEGIN DevCPM.Get(ch); + LOOP + LOOP + WHILE ch = "(" DO DevCPM.Get(ch); + IF ch = "*" THEN Comment END + END ; + IF ch = "*" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN EXIT END ; + DevCPM.Get(ch) + END ; + IF ch = ")" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN err(5); EXIT END + END + END Comment; + + BEGIN + DevCPM.errpos := DevCPM.curpos-1; + WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*) + IF ch = DevCPM.Eot THEN sym := eof; RETURN + ELSE DevCPM.Get(ch) + END + END ; + DevCPM.startpos := DevCPM.curpos - 1; + CASE ch OF (* ch > " " *) + | 22X, 27X : Str(s) + | "#" : s := neq; DevCPM.Get(ch) + | "&" : s := and; DevCPM.Get(ch) + | "(" : DevCPM.Get(ch); + IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; + ELSE s := lparen + END + | ")" : s := rparen; DevCPM.Get(ch) + | "*" : s := times; DevCPM.Get(ch) + | "+" : s := plus; DevCPM.Get(ch) + | "," : s := comma; DevCPM.Get(ch) + | "-" : s := minus; DevCPM.Get(ch) + | "." : DevCPM.Get(ch); + IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END + | "/" : s := slash; DevCPM.Get(ch) + | "0".."9": Number; s := number + | ":" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END + | ";" : s := semicolon; DevCPM.Get(ch) + | "<" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END + | "=" : s := eql; DevCPM.Get(ch) + | ">" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + | "B": Identifier(s); + IF name = "BEGIN" THEN s := begin + ELSIF name = "BY" THEN s := by + END + | "C": Identifier(s); + IF name = "CASE" THEN s := case + ELSIF name = "CONST" THEN s := const + ELSIF name = "CLOSE" THEN s := close + END + | "D": Identifier(s); + IF name = "DO" THEN s := do + ELSIF name = "DIV" THEN s := div + END + | "E": Identifier(s); + IF name = "END" THEN s := end + ELSIF name = "ELSE" THEN s := else + ELSIF name = "ELSIF" THEN s := elsif + ELSIF name = "EXIT" THEN s := exit + END + | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "I": Identifier(s); + IF name = "IF" THEN s := if + ELSIF name = "IN" THEN s := in + ELSIF name = "IS" THEN s := is + ELSIF name = "IMPORT" THEN s := import + END + | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "M": Identifier(s); + IF name = "MOD" THEN s := mod + ELSIF name = "MODULE" THEN s := module + END + | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "O": Identifier(s); + IF name = "OR" THEN s := or + ELSIF name = "OF" THEN s := of + ELSIF name = "OUT" THEN s := out + END + | "P": Identifier(s); + IF name = "PROCEDURE" THEN s := procedure + ELSIF name = "POINTER" THEN s := pointer + END + | "R": Identifier(s); + IF name = "RECORD" THEN s := record + ELSIF name = "REPEAT" THEN s := repeat + ELSIF name = "RETURN" THEN s := return + END + | "T": Identifier(s); + IF name = "THEN" THEN s := then + ELSIF name = "TO" THEN s := to + ELSIF name = "TYPE" THEN s := type + END + | "U": Identifier(s); IF name = "UNTIL" THEN s := until END + | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "W": Identifier(s); + IF name = "WHILE" THEN s := while + ELSIF name = "WITH" THEN s := with + END + | "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_", "À".."Ö", "Ø".."ö", "ø".."ÿ": Identifier(s) + | "[" : s := lbrak; DevCPM.Get(ch) + | "]" : s := rbrak; DevCPM.Get(ch) + | "^" : s := arrow; DevCPM.Get(ch) + | "$" : s := dollar; DevCPM.Get(ch) + | "{" : s := lbrace; DevCPM.Get(ch); + | "|" : s := bar; DevCPM.Get(ch) + | "}" : s := rbrace; DevCPM.Get(ch) + | "~" : s := not; DevCPM.Get(ch) + | 7FX : s := upto; DevCPM.Get(ch) + ELSE s := null; DevCPM.Get(ch) + END ; + sym := s + END Get; + + PROCEDURE Init*; + BEGIN ch := " " + END Init; + +END Dev0CPS. \ No newline at end of file diff --git a/Trurl-based/Dev0/Mod/CPT.odc b/Trurl-based/Dev0/Mod/CPT.odc new file mode 100644 index 0000000..a858cbb Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPT.odc differ diff --git a/Trurl-based/Dev0/Mod/CPT.txt b/Trurl-based/Dev0/Mod/CPT.txt new file mode 100644 index 0000000..c8253ee --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPT.txt @@ -0,0 +1,1904 @@ +MODULE Dev0CPT; + + (* THIS IS TEXT COPY OF CPT.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPM := Dev0CPM; + + CONST + MaxIdLen = 256; + + TYPE + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; + Const* = POINTER TO ConstDesc; + Object* = POINTER TO ObjDesc; + Struct* = POINTER TO StrDesc; + Node* = POINTER TO NodeDesc; + ConstExt* = String; + LinkList* = POINTER TO LinkDesc; + + ConstDesc* = RECORD + ext*: ConstExt; (* string or code for code proc (longstring in utf8) *) + intval*: INTEGER; (* constant value or adr, proc par size, text position or least case label *) + intval2*: INTEGER; (* string length (#char, incl 0X), proc var size or larger case label *) + setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) + realval*: REAL; (* real or longreal constant value *) + link*: Const (* chain of constants present in obj file *) + END ; + + LinkDesc* = RECORD + offset*, linkadr*: INTEGER; + next*: LinkList; + END; + + ObjDesc* = RECORD + left*, right*, link*, scope*: Object; + name*: String; (* name = null OR name^ # "" *) + leaf*: BOOLEAN; + sysflag*: BYTE; + mode*, mnolev*: BYTE; (* mnolev < 0 -> mno = -mnolev *) + vis*: BYTE; (* internal, external, externalR, inPar, outPar *) + history*: BYTE; (* relevant if name # "" *) + used*, fpdone*: BOOLEAN; + fprint*: INTEGER; + typ*: Struct; (* actual type, changed in with statements *) + ptyp*: Struct; (* original type if typ is changed *) + conval*: Const; + adr*, num*: INTEGER; (* mthno *) + links*: LinkList; + nlink*: Object; (* link for name list, declaration order for methods, library link for imp obj *) + library*, entry*: String; (* library name, entry name *) + modifiers*: POINTER TO ARRAY OF String; (* additional interface strings *) + linkadr*: INTEGER; (* used in ofront *) + red: BOOLEAN; + END ; + + StrDesc* = RECORD + form*, comp*, mno*, extlev*: BYTE; + ref*, sysflag*: SHORTINT; + n*, size*, align*, txtpos*: INTEGER; (* align is alignment for records and len offset for dynarrs *) + untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN; + attribute*: BYTE; + idfp, pbfp*, pvfp*:INTEGER; + BaseTyp*: Struct; + link*, strobj*: Object; + ext*: ConstExt (* id string for interface records *) + END ; + + NodeDesc* = RECORD + left*, right*, link*: Node; + class*, subcl*, hint*: BYTE; + readonly*: BOOLEAN; + typ*: Struct; + obj*: Object; + conval*: Const + END ; + + CONST + maxImps = 127; (* must be <= MAX(SHORTINT) *) + maxStruct = DevCPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) + FirstRef = 32; + FirstRef0 = 16; (* correction for version 0 *) + actVersion = 1; + + VAR + topScope*: Object; + undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*, + real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*, + anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*, + restyp*, iunktyp*, punktyp*, guidtyp*, + intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct; + nofGmod*: BYTE; (*nof imports*) + GlbMod*: ARRAY maxImps OF Object; (* .right = first object, .name = module import name (not alias) *) + SelfName*: Name; (* name of module being compiled *) + SYSimported*: BOOLEAN; + processor*, impProc*: SHORTINT; + libName*: Name; (* library alias of module being compiled *) + null*: String; (* "" *) + + CONST + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + AnyPtr = 14; AnyRec = 15; (* sym file only *) + Char16 = 16; String16 = 17; Int64 = 18; + Res = 20; IUnk = 21; PUnk = 22; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* procedure flags (conval.setval) *) + isHidden = 29; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* sysflags *) + inBit = 2; outBit = 4; interface = 10; + + (* symbol file items *) + Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; + Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; + Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; + Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26; + Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22; + + TYPE + ImpCtxt = RECORD + nextTag, reffp: INTEGER; + nofr, minr, nofm: SHORTINT; + self: BOOLEAN; + ref: ARRAY maxStruct OF Struct; + old: ARRAY maxStruct OF Object; + pvfp: ARRAY maxStruct OF INTEGER; (* set only if old # NIL *) + glbmno: ARRAY maxImps OF BYTE (* index is local mno *) + END ; + + ExpCtxt = RECORD + reffp: INTEGER; + ref: SHORTINT; + nofm: BYTE; + locmno: ARRAY maxImps OF BYTE (* index is global mno *) + END ; + + VAR + universe, syslink, comlink, infinity: Object; + impCtxt: ImpCtxt; + expCtxt: ExpCtxt; + nofhdfld: INTEGER; + sfpresent, symExtended, symNew: BOOLEAN; + version: INTEGER; + symChanges: INTEGER; + portable: BOOLEAN; + depth: INTEGER; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewConst*(): Const; + VAR const: Const; + BEGIN NEW(const); RETURN const + END NewConst; + + PROCEDURE NewObj*(): Object; + VAR obj: Object; + BEGIN NEW(obj); obj.name := null; RETURN obj + END NewObj; + + PROCEDURE NewStr*(form, comp: BYTE): Struct; + VAR typ: Struct; + BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *) + typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ + END NewStr; + + PROCEDURE NewNode*(class: BYTE): Node; + VAR node: Node; + BEGIN + NEW(node); node.class := class; RETURN node + END NewNode; +(* + PROCEDURE NewExt*(): ConstExt; + VAR ext: ConstExt; + BEGIN NEW(ext); RETURN ext + END NewExt; +*) + PROCEDURE NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String; + VAR i: INTEGER; p: String; + BEGIN + i := 0; WHILE name[i] # 0X DO INC(i) END; + IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p + ELSE RETURN null + END + END NewName; + + PROCEDURE OpenScope*(level: BYTE; owner: Object); + VAR head: Object; + BEGIN head := NewObj(); + head.mode := Head; head.mnolev := level; head.link := owner; + IF owner # NIL THEN owner.scope := head END ; + head.left := topScope; head.right := NIL; head.scope := NIL; topScope := head + END OpenScope; + + PROCEDURE CloseScope*; + BEGIN topScope := topScope.left + END CloseScope; + + PROCEDURE Init*(opt: SET); + BEGIN + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + GlbMod[0] := topScope; nofGmod := 1; + sfpresent := TRUE; (* !!! *) + symChanges := 0; + infinity.conval.intval := DevCPM.ConstNotAlloc; + depth := 0 + END Init; + + PROCEDURE Open* (name: Name); + BEGIN + SelfName := name$; topScope.name := NewName(name); + END Open; + + PROCEDURE Close*; + VAR i: SHORTINT; + BEGIN (* garbage collection *) + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END + END Close; + + PROCEDURE SameType* (x, y: Struct): BOOLEAN; + BEGIN + RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp) + END SameType; + + PROCEDURE EqualType* (x, y: Struct): BOOLEAN; + VAR xp, yp: Object; n: INTEGER; + BEGIN + n := 0; + WHILE (n < 100) & (x # y) + & (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag)) + OR ((x.form = Pointer) & (y.form = Pointer)) + OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO + IF x.form = ProcTyp THEN + IF x.sysflag # y.sysflag THEN RETURN FALSE END; + xp := x.link; yp := y.link; + INC(depth); + WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag) + & (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO + xp := xp.link; yp := yp.link + END; + DEC(depth); + IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END + END; + x := x.BaseTyp; y := y.BaseTyp; INC(n) + END; + RETURN SameType(x, y) + END EqualType; + + PROCEDURE Extends* (x, y: Struct): BOOLEAN; + BEGIN + IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END; + IF (x.comp = Record) & (y.comp = Record) THEN + IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END; + WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END + END; + RETURN (x # NIL) & EqualType(x, y) + END Extends; + + PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN; + BEGIN + CASE xform OF + | Char16: RETURN yform IN {Char8, Char16, Int8} + | Int16: RETURN yform IN {Char8, Int8, Int16} + | Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32} + | Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64} + | Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32} + | Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64} + | String16: RETURN yform IN {String8, String16} + ELSE RETURN xform = yform + END + END Includes; + + PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object); + VAR obj: Object; (* i: INTEGER; n: Name; *) + BEGIN obj := mod.scope.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) + IF (obj.mode = Typ) & (obj.vis = internal) THEN obj := NIL + ELSE obj.used := TRUE + END ; + EXIT + END + END ; + res := obj; +(* bh: checks usage of non Unicode WinApi functions and types + IF (res # NIL) & (mod.scope.library # NIL) + & ~(DevCPM.interface IN DevCPM.options) + & (SelfName # "Kernel") & (SelfName # "HostPorts") THEN + n := name + "W"; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(733) + ELSE + i := LEN(name$); + IF name[i - 1] = "A" THEN + n[i - 1] := "W"; n[i] := 0X; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(734) + END + END + END + END; +*) + END FindImport; + + PROCEDURE Find*(VAR name: Name; VAR res: Object); + VAR obj, head: Object; + BEGIN head := topScope; + LOOP obj := head.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (* found, obj.used not set for local objects *) EXIT + END + END ; + IF obj # NIL THEN EXIT END ; + head := head.left; + IF head = NIL THEN EXIT END + END ; + res := obj + END Find; + + PROCEDURE FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + VAR obj: Object; + BEGIN + WHILE (typ # NIL) & (typ # undftyp) DO obj := typ.link; + WHILE obj # NIL DO + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) res := obj; RETURN + END + END ; + typ := typ.BaseTyp + END; + res := NIL + END FindFld; + + PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindField; + + PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ.BaseTyp, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindBaseField; + +(* + PROCEDURE Rotated (y: Object; name: String): Object; + VAR c, gc: Object; + BEGIN + IF name^ < y.name^ THEN + c := y.left; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.left := gc + ELSE + c := y.right; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.right := gc + END; + RETURN gc + END Rotated; + + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR gg, g, p, x: Object; name, sname: String; + BEGIN + sname := scope.name; scope.name := null; + gg := scope; g := gg; p := g; x := p.right; name := obj.name; + WHILE x # NIL DO + IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN + x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); x.red := FALSE + END + END; + gg := g; g := p; p := x; + IF name^ < x.name^ THEN x := x.left + ELSIF name^ > x.name^ THEN x := x.right + ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN + END + END; + x := obj; old := NIL; + IF name^ < p.name^ THEN p.left := x ELSE p.right := x END; + x.red := TRUE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); + x.red := FALSE + END; + scope.right.red := FALSE; scope.name := sname + END InsertIn; +*) + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + ASSERT((scope # NIL) & (scope.mode = Head), 100); + ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name; + WHILE ob1 # NIL DO + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + END; + IF left THEN ob0.left := obj ELSE ob0.right := obj END ; + obj.left := NIL; obj.right := NIL; old := NIL + END InsertIn; + + PROCEDURE Insert* (VAR name: Name; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + obj.mnolev := topScope.mnolev; + InsertIn(obj, topScope, old); + IF old # NIL THEN err(1) END (*double def*) + END Insert; + + PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + IF typ.link = NIL THEN typ.link := obj + ELSE + ob1 := typ.link; name := obj.name; + REPEAT + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + UNTIL ob1 = NIL; + IF left THEN ob0.left := obj ELSE ob0.right := obj END + END + END InsertThisField; + + PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + InsertThisField(obj, typ, old); + IF old # NIL THEN err(1) END (*double def*) + END InsertField; + + +(*-------------------------- Fingerprinting --------------------------*) + + PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X + END FPrintName; + + PROCEDURE ^IdFPrint*(typ: Struct); + + PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object); + (* depends on assignment compatibility of params only *) + BEGIN + IdFPrint(result); DevCPM.FPrint(fp, result.idfp); + WHILE par # NIL DO + DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp); + IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END; (* IN / OUT *) + IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END; + (* par.name and par.adr not considered *) + par := par.link + END + END FPrintSign; + + PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *) + VAR btyp: Struct; strobj: Object; idfp: INTEGER; f, c: SHORTINT; + BEGIN + IF ~typ.idfpdone THEN + typ.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *) + idfp := 0; f := typ.form; c := typ.comp; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c); + btyp := typ.BaseTyp; strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN + FPrintName(idfp, GlbMod[typ.mno].name^); FPrintName(idfp, strobj.name^) + END ; + IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN + IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp) + ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.FPrint(idfp, typ.n) + ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ.link) + END ; + typ.idfp := idfp + END + END IdFPrint; + + PROCEDURE FPrintStr*(typ: Struct); + VAR f, c: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER; + + PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER); (* modifies pvfp only *) + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN FPrintFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld); + IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + DevCPM.FPrint(pvfp, fld.vis); FPrintName(pvfp, fld.name^); DevCPM.FPrint(pvfp, fld.adr); + DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr); + FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.FPrint(pvfp, fld.typ.pvfp) + ELSE FPrintHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END FPrintFlds; + + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + VAR fp: INTEGER; + BEGIN + IF obj # NIL THEN + FPrintTProcs(obj.left); + IF obj.mode = TProc THEN + IF obj.vis # internal THEN + fp := 0; + IF obj.vis = externalR THEN DevCPM.FPrint(fp, externalR) END; + IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, limAttr) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, absAttr) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, empAttr) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, extAttr) + END; + DevCPM.FPrint(fp, TProc); DevCPM.FPrint(fp, obj.num); + FPrintSign(fp, obj.typ, obj.link); FPrintName(fp, obj.name^); + IF obj.entry # NIL THEN FPrintName(fp, obj.entry^) END; + DevCPM.FPrint(pvfp, fp); DevCPM.FPrint(pbfp, fp) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num) + END + END; + FPrintTProcs(obj.right) + END + END FPrintTProcs; + + BEGIN + IF ~typ.fpdone THEN + IdFPrint(typ); pbfp := typ.idfp; + IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END; + IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END; + IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) END; + pvfp := pbfp; typ.pbfp := pbfp; typ.pvfp := pvfp; (* initial fprints may be used recursively *) + typ.fpdone := TRUE; + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF f = Pointer THEN + strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj = NIL) OR (strobj.name = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN + FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp + ELSE (* c = Record *) + IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ; + DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n); + nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE); + FPrintTProcs(typ.link); (* DevCPM.FPrint(pvfp, pbfp); *) strobj := typ.strobj; + IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END + END ; + typ.pbfp := pbfp; typ.pvfp := pvfp + END + END FPrintStr; + + PROCEDURE FPrintObj*(obj: Object); + VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER; + BEGIN + IF ~obj.fpdone THEN + fprint := 0; obj.fpdone := TRUE; + DevCPM.FPrint(fprint, obj.mode); + IF obj.mode = Con THEN + f := obj.typ.form; DevCPM.FPrint(fprint, f); + CASE f OF + | Bool, Char8, Char16, Int8, Int16, Int32: + DevCPM.FPrint(fprint, obj.conval.intval) + | Int64: + x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0)); + r := obj.conval.realval + obj.conval.intval - x * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + DevCPM.FPrint(fprint, SHORT(ENTIER(r))); + DevCPM.FPrint(fprint, x) + | Set: + DevCPM.FPrintSet(fprint, obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval) + | Real64: + DevCPM.FPrintLReal(fprint, obj.conval.realval) + | String8, String16: + FPrintName(fprint, obj.conval.ext^) + | NilTyp: + ELSE err(127) + END + ELSIF obj.mode = Var THEN + DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + ELSIF obj.mode IN {XProc, IProc} THEN + FPrintSign(fprint, obj.typ, obj.link) + ELSIF obj.mode = CProc THEN + FPrintSign(fprint, obj.typ, obj.link); ext := obj.conval.ext; + m := ORD(ext^[0]); f := 1; DevCPM.FPrint(fprint, m); + WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END + ELSIF obj.mode = Typ THEN + FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + END ; + IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END; + IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN + IF obj.library # NIL THEN + FPrintName(fprint, obj.library^) + ELSIF obj.mnolev < 0 THEN + mod := GlbMod[-obj.mnolev]; + IF (mod.library # NIL) THEN + FPrintName(fprint, mod.library^) + END + ELSIF obj.mnolev = 0 THEN + IF libName # "" THEN FPrintName(fprint, libName) END + END; + IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END + END; + obj.fprint := fprint + END + END FPrintObj; + + PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT); (* !!! *) + CONST + nl = 0DX; + BEGIN + IF errno = 249 THEN + DevCPM.errorMes := DevCPM.errorMes + nl + " "; + DevCPM.errorMes := DevCPM.errorMes + GlbMod[-obj.mnolev].name^; + DevCPM.errorMes := DevCPM.errorMes + "." + obj.name^; + DevCPM.errorMes := DevCPM.errorMes +" is not consistently imported"; + err(249) + ELSIF obj = NIL THEN (* changed module sys flags *) + IF ~symNew & sfpresent THEN + DevCPM.errorMes := DevCPM.errorMes + nl + " changed library flag" + END + ELSIF obj.mnolev = 0 THEN (* don't report changes in imported modules *) + IF sfpresent THEN + IF symChanges < 20 THEN + DevCPM.errorMes := DevCPM.errorMes + nl + " " + obj.name^; + IF errno = 250 THEN DevCPM.errorMes := DevCPM.errorMes + " is no longer in symbol file" + ELSIF errno = 251 THEN DevCPM.errorMes := DevCPM.errorMes + " is redefined internally " + ELSIF errno = 252 THEN DevCPM.errorMes := DevCPM.errorMes + " is redefined" + ELSIF errno = 253 THEN DevCPM.errorMes := DevCPM.errorMes + " is new in symbol file" + END + ELSIF symChanges = 20 THEN + DevCPM.errorMes := DevCPM.errorMes + nl + " ..." + END; + INC(symChanges) + ELSIF (errno = 253) & ~symExtended THEN + DevCPM.errorMes := DevCPM.errorMes + nl + " new symbol file" + END + END; + IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END + END FPrintErr; + +(*-------------------------- Import --------------------------*) + + PROCEDURE InName(VAR name: String); + VAR i: SHORTINT; ch: SHORTCHAR; n: Name; + BEGIN i := 0; + REPEAT + DevCPM.SymRCh(ch); n[i] := ch; INC(i) + UNTIL ch = 0X; + IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END + END InName; + + PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE); (* mno is global *) + VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String; + BEGIN + IF tag = 0 THEN mno := impCtxt.glbmno[0] + ELSIF tag > 0 THEN + lib := NIL; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + ASSERT(tag = Smname); + InName(name); + IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) THEN err(154) END ; + i := 0; + WHILE (i < nofGmod) & (name^ # GlbMod[i].name^) DO INC(i) END ; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head.mode := Head; head.name := name; + mno := nofGmod; head.mnolev := SHORT(SHORT(-mno)); + head.library := lib; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END ; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-tag] + END + END InMod; + + PROCEDURE InConstant(f: INTEGER; conval: Const); + VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name; + BEGIN + CASE f OF + | Byte, Char8, Bool: + DevCPM.SymRCh(ch); conval.intval := ORD(ch) + | Char16: + DevCPM.SymRCh(ch); conval.intval := ORD(ch); + DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256 + | Int8, Int16, Int32: + conval.intval := DevCPM.SymRInt() + | Int64: + DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*); + WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO + x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch) + END; + WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END; + conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s; + conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval)) + | Set: + DevCPM.SymRSet(conval.setval) + | Real32: + DevCPM.SymRReal(rval); conval.realval := rval; + conval.intval := DevCPM.ConstNotAlloc + | Real64: + DevCPM.SymRLReal(conval.realval); + conval.intval := DevCPM.ConstNotAlloc + | String8, String16: + i := 0; + REPEAT + DevCPM.SymRCh(ch); + IF i < LEN(str) - 1 THEN str[i] := ch + ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch + ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch + ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch + END; + INC(i) + UNTIL ch = 0X; + IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END; + conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc; + IF f = String8 THEN conval.intval2 := i + ELSE + i := 0; y := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0; + conval.intval2 := y + END +(* + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc + | String16: + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i); + DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i) + UNTIL (ch = 0X) & (ch1 = 0X); + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc +*) + | NilTyp: + conval.intval := 0 +(* + | Guid: + ext := NewExt(); conval.ext := ext; i := 0; + WHILE i < 16 DO + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + END; + ext[16] := 0X; + conval.intval2 := 16; + conval.intval := DevCPM.ConstNotAlloc; +*) + END + END InConstant; + + PROCEDURE ^InStruct(VAR typ: Struct); + + PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object); + VAR last, new: Object; tag: INTEGER; + BEGIN + InStruct(res); + tag := DevCPM.SymRInt(); last := NIL; + WHILE tag # Send DO + new := NewObj(); new.mnolev := SHORT(SHORT(-mno)); + IF last = NIL THEN par := new ELSE last.link := new END ; + IF tag = Ssys THEN + new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt(); + IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar + ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar + END + END; + IF tag = Svalpar THEN new.mode := Var + ELSE new.mode := VarPar; + IF tag = Sinpar THEN new.vis := inPar + ELSIF tag = Soutpar THEN new.vis := outPar + END + END ; + InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name); + last := new; tag := DevCPM.SymRInt() + END + END InSign; + + PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj.mode := Fld; + IF tag = Srfld THEN obj.vis := externalR ELSE obj.vis := external END ; + InStruct(obj.typ); InName(obj.name); + obj.adr := DevCPM.SymRInt() + ELSE + obj.mode := Fld; + IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName) + ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName); (* !!! *) + obj.sysflag := 1 + ELSIF tag = Ssys THEN + obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())) + ELSE obj.name := NewName(DevCPM.HdProcName) + END; + obj.typ := undftyp; obj.vis := internal; + obj.adr := DevCPM.SymRInt() + END; + RETURN obj + END InFld; + + PROCEDURE InTProc(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); + IF tag = Shdtpro THEN + obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName); + obj.link := NewObj(); (* dummy, easier in Browser *) + obj.typ := undftyp; obj.vis := internal; + obj.num := DevCPM.SymRInt() + ELSE + obj.vis := external; + IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END; + obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1; + IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END; + InSign(mno, obj.typ, obj.link); InName(obj.name); + obj.num := DevCPM.SymRInt(); + IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr) + ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr) + ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr) + ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr) + END + END ; + RETURN obj + END InTProc; + + PROCEDURE InStruct(VAR typ: Struct); + VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String; + t: Struct; obj, last, fld, old, dummy: Object; + BEGIN + tag := DevCPM.SymRInt(); + IF tag # Sstruct THEN + tag := -tag; + IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END; (* correction for new FirstRef *) + typ := impCtxt.ref[tag] + ELSE + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; + tag := DevCPM.SymRInt(); + InMod(tag, mno); InName(name); obj := NewObj(); + IF name = null THEN + IF impCtxt.self THEN old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null + END ; + typ := NewStr(Undef, Basic) + ELSE obj.name := name; InsertIn(obj, GlbMod[mno], old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old.typ.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(Undef, Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old.typ; typ.link := NIL; typ.sysflag := 0; typ.ext := NIL; + typ.fpdone := FALSE; typ.idfpdone := FALSE + END + ELSE typ := NewStr(Undef, Basic) + END + END ; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(ref + maxStruct); + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ.mno := mno; typ.allocated := TRUE; + typ.strobj := obj; obj.mode := Typ; obj.typ := typ; + obj.mnolev := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *) + tag := DevCPM.SymRInt(); + IF tag = Ssys THEN + typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt() + END; + typ.untagged := typ.sysflag > 0; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag = String8 THEN + InName(typ.ext); tag := DevCPM.SymRInt() + END; + CASE tag OF + | Sptr: + typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp) + | Sarr: + typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt(); + typ.size := typ.n * typ.BaseTyp.size (* !!! *) + | Sdarr: + typ.form := Comp; typ.comp := DynArr; InStruct(typ.BaseTyp); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 + ELSE typ.n := 0 + END ; + typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n; (* !!! *) + IF typ.untagged THEN typ.size := DevCPM.PointerSize END + | Srec, Sabsrec, Slimrec, Sextrec: + typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp); + (* correction by ETH 18.1.96 *) + IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END; + typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt(); + typ.n := DevCPM.SymRInt(); + IF tag = Sabsrec THEN typ.attribute := absAttr + ELSIF tag = Slimrec THEN typ.attribute := limAttr + ELSIF tag = Sextrec THEN typ.attribute := extAttr + END; + impCtxt.nextTag := DevCPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) + OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO + fld := InFld(); fld.mnolev := SHORT(SHORT(-mno)); + IF last # NIL THEN last.link := fld END ; + last := fld; + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END ; + WHILE impCtxt.nextTag # Send DO fld := InTProc(mno); + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END + | Spro: + typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link) + | Salias: + InStruct(t); + typ.form := t.form; typ.comp := Basic; typ.size := t.size; + typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE; + typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t + END ; + IF ref = impCtxt.minr THEN + WHILE ref < impCtxt.nofr DO + t := impCtxt.ref[ref]; FPrintStr(t); + obj := t.strobj; (* obj.typ.strobj = obj, else obj.fprint differs (alias) *) + IF obj.name # null THEN FPrintObj(obj) END ; + old := impCtxt.old[ref]; + IF old # NIL THEN t.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old.mnolev < 0 THEN + IF old.history # inconsistent THEN + IF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + END + (* ELSE remain inconsistent *) + END + ELSIF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + ELSIF old.vis = internal THEN old.history := same (* may be changed to "removed" in InObj *) + ELSE old.history := inserted (* may be changed to "same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t.pvfp THEN old.history := inconsistent END ; + IF old.fprint # obj.fprint THEN FPrintErr(old, 249) END + END + ELSIF impCtxt.self THEN obj.history := removed + ELSE obj.history := same + END ; + INC(ref) + END ; + impCtxt.minr := maxStruct + END + END + END InStruct; + + PROCEDURE InObj(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR ch: SHORTCHAR; obj, old: Object; typ: Struct; + tag, i, s: INTEGER; ext: ConstExt; + BEGIN + tag := impCtxt.nextTag; + IF tag = Stype THEN + InStruct(typ); obj := typ.strobj; + IF ~impCtxt.self THEN obj.vis := external END (* type name visible now, obj.fprint already done *) + ELSE + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); obj.vis := external; + IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag >= Sxpro THEN + IF obj.conval = NIL THEN obj.conval := NewConst() END; + obj.conval.intval := -1; + InSign(mno, obj.typ, obj.link); + CASE tag OF + | Sxpro: obj.mode := XProc + | Sipro: obj.mode := IProc + | Scpro: obj.mode := CProc; + s := DevCPM.SymRInt(); + NEW(ext, s + 1); obj.conval.ext := ext; + ext^[0] := SHORT(CHR(s)); i := 1; + WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END + END + ELSIF tag = Salias THEN + obj.mode := Typ; InStruct(obj.typ) + ELSIF (tag = Svar) OR (tag = Srvar) THEN + obj.mode := Var; + IF tag = Srvar THEN obj.vis := externalR END ; + InStruct(obj.typ) + ELSE (* Constant *) + obj.conval := NewConst(); InConstant(tag, obj.conval); + IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END; + obj.mode := Con; obj.typ := impCtxt.ref[tag]; + END ; + InName(obj.name) + END ; + FPrintObj(obj); + IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct) + END ; + IF tag # Stype THEN + InsertIn(obj, GlbMod[mno], old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old.vis = internal THEN old.history := removed + ELSE FPrintObj(old); FPrintStr(old.typ); (* FPrint(obj) already called *) + IF obj.fprint # old.fprint THEN old.history := pbmodified + ELSIF obj.typ.pvfp # old.typ.pvfp THEN old.history := pvmodified + ELSE old.history := same + END + END + ELSE obj.history := removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already inserted in InStruct *) + IF impCtxt.self THEN (* obj.mnolev = 0 *) + IF obj.vis = internal THEN obj.history := removed + ELSIF obj.history = inserted THEN obj.history := same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END ; + RETURN obj + END InObj; + + PROCEDURE Import*(aliasName: Name; VAR name: Name; VAR done: BOOLEAN); + VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String; (* done used in Browser *) + BEGIN + IF name = "SYSTEM" THEN + SYSimported := TRUE; + p := processor; + IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END; + INCL(DevCPM.options, p); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h + ELSIF name = "COM" THEN + IF DevCPM.comAware IN DevCPM.options THEN + INCL(DevCPM.options, DevCPM.com); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h; + ELSE err(151) + END; + ELSIF name = "JAVA" THEN + INCL(DevCPM.options, DevCPM.java) + ELSE + impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + DevCPM.OldSym(name, done); + IF done THEN + lib := NIL; + impProc := SHORT(DevCPM.SymRInt()); + IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END; + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + tag := DevCPM.SymRInt(); + IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt() + ELSE version := 0 + END; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + InMod(tag, mno); + IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN (* symbol file name conflict *) + GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm); + DevCPM.CloseOldSym; done := FALSE + END; + END; + IF done THEN + GlbMod[mno].library := lib; + impCtxt.nextTag := DevCPM.SymRInt(); + WHILE ~DevCPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt() + END ; + Insert(aliasName, obj); + obj.mode := Mod; obj.scope := GlbMod[mno](*.right*); + GlbMod[mno].link := obj; + obj.mnolev := SHORT(SHORT(-mno)); obj.typ := notyp; + DevCPM.CloseOldSym + ELSIF impCtxt.self THEN + sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END + END Import; + +(*-------------------------- Export --------------------------*) + + PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE OutMod(mno: SHORTINT); + VAR mod: Object; + BEGIN + IF expCtxt.locmno[mno] < 0 THEN (* new mod *) + mod := GlbMod[mno]; + IF mod.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(mod.library^) + END; + DevCPM.SymWInt(Smname); + expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm); + OutName(mod.name^) + ELSE DevCPM.SymWInt(-expCtxt.locmno[mno]) + END + END OutMod; + + PROCEDURE ^OutStr(typ: Struct); + PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER); + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN OutFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; OutHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Ssys); (* DevCPM.SymWInt(Shdutptr); *) + IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END; + DevCPM.SymWInt(n); + DevCPM.SymWInt(adr); INC(nofhdfld); + IF n > 1 THEN portable := FALSE END (* hidden untagged pointer are portable *) + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld) + END + END OutHdFld; + + PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ; + OutStr(fld.typ); OutName(fld.name^); DevCPM.SymWInt(fld.adr) + ELSE OutHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END OutFlds; + + PROCEDURE OutSign(result: Struct; par: Object); + BEGIN + OutStr(result); + WHILE par # NIL DO + IF par.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END; + IF par.mode = Var THEN DevCPM.SymWInt(Svalpar) + ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar) + ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar) + ELSE DevCPM.SymWInt(Svarpar) + END ; + OutStr(par.typ); + DevCPM.SymWInt(par.adr); + OutName(par.name^); par := par.link + END ; + DevCPM.SymWInt(Send) + END OutSign; + + PROCEDURE OutTProcs(typ: Struct; obj: Object); + VAR bObj: Object; + BEGIN + IF obj # NIL THEN + IF obj.mode = TProc THEN +(* + IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN + FindBaseField(obj.name^, typ, bObj); + ASSERT((bObj # NIL) & (bObj.num = obj.num)); + IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END + (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) + END; +*) + IF obj.vis # internal THEN + IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END; + IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro) + ELSE DevCPM.SymWInt(Stpro) + END; + OutSign(obj.typ, obj.link); OutName(obj.name^); + DevCPM.SymWInt(obj.num) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.SymWInt(Shdtpro); + DevCPM.SymWInt(obj.num) + END + END; + OutTProcs(typ, obj.left); + OutTProcs(typ, obj.right) + END + END OutTProcs; + + PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *) + VAR strobj: Object; + BEGIN + IF typ.ref < expCtxt.ref THEN DevCPM.SymWInt(-typ.ref) + ELSE + DevCPM.SymWInt(Sstruct); + typ.ref := expCtxt.ref; INC(expCtxt.ref); + IF expCtxt.ref >= maxStruct THEN err(228) END ; + OutMod(typ.mno); strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN OutName(strobj.name^); + CASE strobj.history OF + | pbmodified: FPrintErr(strobj, 252) + | pvmodified: FPrintErr(strobj, 251) + | inconsistent: FPrintErr(strobj, 249) + ELSE (* checked in OutObj or correct indirect export *) + END + ELSE DevCPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) + END; + IF typ.sysflag # 0 THEN (* !!! *) + DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag); + IF typ.sysflag > 0 THEN portable := FALSE END + END; + IF strobj # NIL THEN + IF strobj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE + END; + IF strobj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE + END + END; + IF typ.ext # NIL THEN + DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE + END; + CASE typ.form OF + | Pointer: + DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp) + | ProcTyp: + DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link) + | Comp: + CASE typ.comp OF + | Array: + DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n) + | DynArr: + DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp) + | Record: + IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec) + ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec) + ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec) + ELSE DevCPM.SymWInt(Srec) + END; + IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ; + (* BaseTyp should be Notyp, too late to change *) + DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n); + nofhdfld := 0; OutFlds(typ.link, 0, TRUE); +(* + IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ; (* !!! *) +*) + OutTProcs(typ, typ.link); DevCPM.SymWInt(Send) + END + ELSE (* alias structure *) + DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp) + END + END + END OutStr; + + PROCEDURE OutConstant(obj: Object); + VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL; + BEGIN + f := obj.typ.form; +(* + IF obj.typ = guidtyp THEN f := Guid END; +*) + IF f = Int32 THEN + IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8 + ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16 + END + END; + DevCPM.SymWInt(f); + CASE f OF + | Bool, Char8: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval))) + | Char16: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256))); + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256))) + | Int8, Int16, Int32: + DevCPM.SymWInt(obj.conval.intval) + | Int64: + IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN + a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1 + ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 2097152.0 (*2^21*))); + b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1 + ELSE + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*))); + r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*); + b := SHORT(ENTIER(r / 2097152.0 (*2^21*))); + c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*))) + END; + IF c >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))) + END; + IF b >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))) + END; + DevCPM.SymWInt(a) + | Set: + DevCPM.SymWSet(obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval) + | Real64: + DevCPM.SymWLReal(obj.conval.realval) + | String8, String16: + OutName(obj.conval.ext^) + | NilTyp: +(* + | Guid: + i := 0; + WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END +*) + ELSE err(127) + END + END OutConstant; + + PROCEDURE OutObj(obj: Object); + VAR i, j: SHORTINT; ext: ConstExt; + BEGIN + IF obj # NIL THEN + OutObj(obj.left); + IF obj.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN + IF obj.history = removed THEN FPrintErr(obj, 250) + ELSIF obj.vis # internal THEN + CASE obj.history OF + | inserted: FPrintErr(obj, 253) + | same: (* ok *) + | pbmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END + | pvmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END + END ; + IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END; + IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN + (* name alias for types handled in OutStr *) + IF obj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE + END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END + END; + CASE obj.mode OF + | Con: + OutConstant(obj); OutName(obj.name^) + | Typ: + IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ) + ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^) + END + | Var: + IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ; + OutStr(obj.typ); OutName(obj.name^); + IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN + (* compute fingerprint to avoid structural type equivalence *) + DevCPM.FPrint(expCtxt.reffp, obj.typ.ref) + END + | XProc: + DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | IProc: + DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | CProc: + DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext; + j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j); + WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ; + OutName(obj.name^); portable := FALSE + END + END + END ; + OutObj(obj.right) + END + END OutObj; + + PROCEDURE Export*(VAR ext, new: BOOLEAN); + VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object; oldCSum: INTEGER; + BEGIN + symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; + Import("@self", SelfName, done); nofGmod := nofmod; + oldCSum := DevCPM.checksum; + ASSERT(GlbMod[0].name^ = SelfName); + IF DevCPM.noerr THEN (* ~DevCPM.noerr => ~done *) + DevCPM.NewSym(SelfName); + IF DevCPM.noerr THEN + DevCPM.SymWInt(0); (* portable symfile *) + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + DevCPM.SymWInt(actVersion); + old := GlbMod[0]; portable := TRUE; + IF libName # "" THEN + DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE; + IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN + FPrintErr(NIL, 252) + END + ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252) + END; + DevCPM.SymWInt(Smname); OutName(SelfName); + expCtxt.reffp := 0; expCtxt.ref := FirstRef; + expCtxt.nofm := 1; expCtxt.locmno[0] := 0; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; + OutObj(topScope.right); + ext := sfpresent & symExtended; + new := ~sfpresent OR symNew OR (DevCPM.checksum # oldCSum); + IF DevCPM.noerr & ~portable THEN + DevCPM.SymReset; + DevCPM.SymWInt(processor) (* nonportable symfile *) + END; + IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN + new := TRUE + END ; + IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END + (* DevCPM.RegisterNewSym is called in OP2 after writing the object file *) + END + END + END Export; (* no new symbol file if ~DevCPM.noerr *) + + + PROCEDURE InitStruct(VAR typ: Struct; form: BYTE); + BEGIN + typ := NewStr(form, Basic); typ.ref := form; typ.size := 1; typ.allocated := TRUE; + typ.strobj := NewObj(); typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE + END InitStruct; + + PROCEDURE EnterBoolConst(name: Name; val: INTEGER); + VAR obj: Object; + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val + END EnterBoolConst; + + PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object); + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val + END EnterRealConst; + + PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; VAR res: Struct); + VAR obj: Object; typ: Struct; + BEGIN + Insert(name, obj); + typ := NewStr(form, Basic); obj.mode := Typ; obj.typ := typ; obj.vis := external; + typ.strobj := obj; typ.size := size; typ.ref := form; typ.allocated := TRUE; + typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE; res := typ + END EnterTyp; + + PROCEDURE EnterProc(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := SProc; obj.typ := notyp; obj.adr := num + END EnterProc; + + PROCEDURE EnterAttr(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := Attr; obj.adr := num + END EnterAttr; + + PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT); + VAR obj, par: Object; + BEGIN + InsertField(name, rec, obj); + obj.mnolev := -128; (* for correct implement only behaviour *) + obj.mode := TProc; obj.num := num; obj.conval := NewConst(); + obj.conval.setval := obj.conval.setval + {newAttr}; + IF typ = 0 THEN (* FINALIZE, RELEASE *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, empAttr) + ELSIF typ = 1 THEN (* QueryInterface *) + par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar; + par.sysflag := 8; par.adr := 16; par.typ := punktyp; + par.link := obj.link; obj.link := par; + par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar; + par.sysflag := 16; par.adr := 12; par.typ := guidtyp; + par.link := obj.link; obj.link := par; + obj.typ := restyp; obj.vis := external; + INCL(obj.conval.setval, extAttr) + ELSIF typ = 2 THEN (* AddRef, Release *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, isHidden); + INCL(obj.conval.setval, extAttr) + END; + par := NewObj(); par.name := NewName("this"); par.mode := Var; + par.adr := 8; par.typ := ptr; + par.link := obj.link; obj.link := par; + END EnterTProc; + + PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT); + VAR obj: Object; + BEGIN + obj := NewObj(); obj.mode := Fld; + obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs; + obj.link := root; root := obj + END EnterHdField; + +BEGIN + NEW(null, 1); null^ := ""; + topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0; + InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp); + InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize; + InitStruct(string16typ, String16); + undftyp.BaseTyp := undftyp; + + (*initialization of module SYSTEM*) +(* + EnterTyp("BYTE", Byte, 1, bytetyp); + EnterProc("NEW", sysnewfn); +*) + EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp); + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); + EnterProc("CC", ccfn); + EnterProc("LSH", lshfn); + EnterProc("ROT", rotfn); + EnterProc("GET", getfn); + EnterProc("PUT", putfn); + EnterProc("GETREG", getrfn); + EnterProc("PUTREG", putrfn); + EnterProc("BIT", bitfn); + EnterProc("VAL", valfn); + EnterProc("MOVE", movefn); + EnterProc("THISRECORD", thisrecfn); + EnterProc("THISARRAY", thisarrfn); + syslink := topScope.right; topScope.right := NIL; + + (* initialization of module COM *) + EnterProc("ID", iidfn); + EnterProc("QUERY", queryfn); + EnterTyp("RESULT", Int32, 4, restyp); + restyp.ref := Res; + EnterTyp("GUID", Guid, 16, guidtyp); + guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16; + EnterTyp("IUnknown^", IUnk, 12, iunktyp); + iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3; + iunktyp.attribute := absAttr; +(* + EnterHdField(iunktyp.link, 12); +*) + iunktyp.BaseTyp := NIL; iunktyp.align := 4; + iunktyp.sysflag := interface; iunktyp.untagged := TRUE; + NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}"; + EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp); + punktyp.form := Pointer; punktyp.BaseTyp := iunktyp; + punktyp.sysflag := interface; punktyp.untagged := TRUE; + EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1); + EnterTProc(punktyp, iunktyp, "AddRef", 1, 2); + EnterTProc(punktyp, iunktyp, "Release", 2, 2); + comlink := topScope.right; topScope.right := NIL; + + universe := topScope; + EnterProc("LCHR", lchrfn); + EnterProc("LENTIER", lentierfcn); + EnterTyp("ANYREC", AnyRec, 0, anytyp); + anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1; + anytyp.BaseTyp := NIL; anytyp.extlev := -1; (* !!! *) + anytyp.attribute := absAttr; + EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp); + anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp; + EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0); + EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0); + EnterProc("VALID", validfn); + + EnterTyp("SHORTCHAR", Char8, 1, char8typ); + string8typ.BaseTyp := char8typ; + EnterTyp("CHAR", Char16, 2, char16typ); + EnterTyp("LONGCHAR", Char16, 2, lchar16typ); + string16typ.BaseTyp := char16typ; + EnterTyp("SET", Set, 4, settyp); + EnterTyp("BYTE", Int8, 1, int8typ); + guidtyp.BaseTyp := int8typ; + EnterTyp("SHORTINT", Int16, 2, int16typ); + EnterTyp("INTEGER", Int32, 4, int32typ); + EnterTyp("LONGINT", Int64, 8, int64typ); + EnterTyp("LARGEINT", Int64, 8, lint64typ); + EnterTyp("SHORTREAL", Real32, 4, real32typ); + EnterTyp("REAL", Real64, 8, real64typ); + EnterTyp("LONGREAL", Real64, 8, lreal64typ); + EnterTyp("BOOLEAN", Bool, 1, booltyp); + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) + EnterBoolConst("TRUE", 1); + EnterRealConst("INF", DevCPM.InfReal, infinity); + EnterProc("HALT", haltfn); + EnterProc("NEW", newfn); + EnterProc("ABS", absfn); + EnterProc("CAP", capfn); + EnterProc("ORD", ordfn); + EnterProc("ENTIER", entierfn); + EnterProc("ODD", oddfn); + EnterProc("MIN", minfn); + EnterProc("MAX", maxfn); + EnterProc("CHR", chrfn); + EnterProc("SHORT", shortfn); + EnterProc("LONG", longfn); + EnterProc("SIZE", sizefn); + EnterProc("INC", incfn); + EnterProc("DEC", decfn); + EnterProc("INCL", inclfn); + EnterProc("EXCL", exclfn); + EnterProc("LEN", lenfn); + EnterProc("COPY", copyfn); + EnterProc("ASH", ashfn); + EnterProc("ASSERT", assertfn); +(* + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); +*) + EnterProc("BITS", bitsfn); + EnterAttr("ABSTRACT", absAttr); + EnterAttr("LIMITED", limAttr); + EnterAttr("EMPTY", empAttr); + EnterAttr("EXTENSIBLE", extAttr); + NEW(intrealtyp); intrealtyp^ := real64typ^; + impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; + impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char8] := char8typ; + impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; + impCtxt.ref[Int32] := int32typ; impCtxt.ref[Real32] := real32typ; + impCtxt.ref[Real64] := real64typ; impCtxt.ref[Set] := settyp; + impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp; + impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp; + impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp; + impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ; + impCtxt.ref[Int64] := int64typ; + impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp; + impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp; +END Dev0CPT. + +Objects: + + mode | adr conval link scope leaf + ------------------------------------------------ + Undef | Not used + Var | vadr next regopt Glob or loc var or proc value parameter + VarPar| vadr next regopt Var parameter (vis = 0 | inPar | outPar) + Con | val Constant + Fld | off next Record field + Typ | Named type + LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end + XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end + SProc | fno sizes Standard procedure + CProc | code firstpar scope Code procedure + IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end + Mod | scope Module + Head | txtpos owner firstvar Scope anchor + TProc | entry sizes firstpar scope leaf Bound procedure, mthno = obj.num + + Structures: + + form comp | n BaseTyp link mno txtpos sysflag + ---------------------------------------------------------------------------------- + Undef Basic | + Byte Basic | + Bool Basic | + Char8 Basic | + Int8 Basic | + Int16 Basic | + Int32 Basic | + Real32 Basic | + Real64 Basic | + Set Basic | + String8 Basic | + NilTyp Basic | + NoTyp Basic | + Pointer Basic | PBaseTyp mno txtpos sysflag + ProcTyp Basic | ResTyp params mno txtpos sysflag + Comp Array | nofel ElemTyp mno txtpos sysflag + Comp DynArr| dim ElemTyp mno txtpos sysflag + Comp Record| nofmth RBaseTyp fields mno txtpos sysflag + Char16 Basic | + String16Basic | + Int64 Basic | + +Nodes: + +design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc. +expr = design|Nconst|Nupto|Nmop|Ndop|Ncall. +nextexpr = NIL|expr. +ifstat = NIL|Nif. +casestat = Ncaselse. +sglcase = NIL|Ncasedo. +stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat| + Nloop|Nexit|Nreturn|Nwith|Ntrap. + + + class subcl obj left right link + --------------------------------------------------------- + +design Nvar var nextexpr + Nvarpar varpar nextexpr + Nfield field design nextexpr + Nderef ptr/str design nextexpr + Nindex design expr nextexpr + Nguard design nextexpr (typ = guard type) + Neguard design nextexpr (typ = guard type) + Ntype type nextexpr + Nproc normal proc nextexpr + super proc nextexpr + + +expr design + Nconst const (val = node.conval) + Nupto expr expr nextexpr + Nmop not expr nextexpr + minus expr nextexpr + is tsttype expr nextexpr + conv expr nextexpr + abs expr nextexpr + cap expr nextexpr + odd expr nextexpr + bit expr nextexpr {x} + adr expr nextexpr SYSTEM.ADR + typ expr nextexpr SYSTEM.TYP + cc Nconst nextexpr SYSTEM.CC + val expr nextexpr SYSTEM.VAL + Ndop times expr expr nextexpr + slash expr expr nextexpr + div expr expr nextexpr + mod expr expr nextexpr + and expr expr nextexpr + plus expr expr nextexpr + minus expr expr nextexpr + or expr expr nextexpr + eql expr expr nextexpr + neq expr expr nextexpr + lss expr expr nextexpr + leq expr expr nextexpr + grt expr expr nextexpr + geq expr expr nextexpr + in expr expr nextexpr + ash expr expr nextexpr + msk expr Nconst nextexpr + len design Nconst nextexpr + min expr expr nextexpr MIN + max expr expr nextexpr MAX + bit expr expr nextexpr SYSTEM.BIT + lsh expr expr nextexpr SYSTEM.LSH + rot expr expr nextexpr SYSTEM.ROT + Ncall fpar design nextexpr nextexpr + Ncomp stat expr nextexpr + +nextexpr NIL + expr + +ifstat NIL + Nif expr stat ifstat + +casestat Ncaselse sglcase stat (minmax = node.conval) + +sglcase NIL + Ncasedo Nconst stat sglcase + +stat NIL + Ninittd stat (of node.typ) + Nenter proc stat stat stat (proc=NIL for mod) + Nassign assign design expr stat + newfn design nextexp stat + incfn design expr stat + decfn design expr stat + inclfn design expr stat + exclfn design expr stat + copyfn design expr stat + getfn design expr stat SYSTEM.GET + putfn expr expr stat SYSTEM.PUT + getrfn design Nconst stat SYSTEM.GETREG + putrfn Nconst expr stat SYSTEM.PUTREG + sysnewfn design expr stat SYSTEM.NEW + movefn expr expr stat SYSTEM.MOVE + (right.link = 3rd par) + Ncall fpar design nextexpr stat + Nifelse ifstat stat stat + Ncase expr casestat stat + Nwhile expr stat stat + Nrepeat stat expr stat + Nloop stat stat + Nexit stat + Nreturn proc nextexpr stat (proc = NIL for mod) + Nwith ifstat stat stat + Ntrap expr stat + Ncomp stat stat stat diff --git a/Trurl-based/Dev0/Mod/CPV486.odc b/Trurl-based/Dev0/Mod/CPV486.odc new file mode 100644 index 0000000..3e32c73 Binary files /dev/null and b/Trurl-based/Dev0/Mod/CPV486.odc differ diff --git a/Trurl-based/Dev0/Mod/CPV486.txt b/Trurl-based/Dev0/Mod/CPV486.txt new file mode 100644 index 0000000..c45e892 --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPV486.txt @@ -0,0 +1,1788 @@ +MODULE Dev0CPV486; + + (* THIS IS TEXT COPY OF CPV486.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPE := Dev0CPE, + DevCPH := Dev0CPH, DevCPL486 := Dev0CPL486, DevCPC486 := Dev0CPC486; + + CONST + processor* = 10; (* for i386 *) + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + + (*SYSTEM function number*) + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* COM function number *) + validfn = 40; queryfn = 42; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24; + wreg = {AX, BX, CX, DX, SI, DI}; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* sysflag *) + untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7; + interface = 10; guarded = 8; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + ParOff = 8; + interfaceSize = 16; (* SIZE(Kernel.Interface) *) + addRefFP = 4E27A847H; (* fingerprint of AddRef and Release procedures *) + intHandlerFP = 24B0EAE3H; (* fingerprint of InterfaceTrapHandler *) + numPreIntProc = 2; + + + VAR + Exit, Return: DevCPL486.Label; + assert, sequential: BOOLEAN; + nesting, actual: INTEGER; + query, addRef, release, release2: DevCPT.Object; + + PROCEDURE Init*(opt: SET); + CONST ass = 2; + BEGIN + DevCPL486.Init(opt); DevCPC486.Init(opt); + assert := ass IN opt; + DevCPM.breakpc := MAX(INTEGER); + query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL; + END Init; + + PROCEDURE Close*; + BEGIN + DevCPL486.Close + END Close; + + PROCEDURE Align(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: INC(offset, offset MOD 2) + | 4: INC(offset, (-offset) MOD 4) + | 8: INC(offset, (-offset) MOD 8) + END + END Align; + + PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: DEC(offset, offset MOD 2) + | 4: DEC(offset, offset MOD 4) + | 8: DEC(offset, offset MOD 8) + END + END NegAlign; + + PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER; (* typ.comp # DynArr *) + VAR align: INTEGER; + BEGIN + WHILE typ.comp = Array DO typ := typ.BaseTyp END ; + IF typ.comp = Record THEN + align := typ.align + ELSE + align := typ.size; + END; + IF align > limit THEN RETURN limit ELSE RETURN align END + END Base; + +(* ----------------------------------------------------- + reference implementation of TypeSize for portable symbol files + mandatory for all non-system structures + + PROCEDURE TypeSize (typ: DevCPT.Struct); + VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; TypeSize(btyp); + IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4) + ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2) + END; + fld.adr := offset; INC(offset, btyp.size); + fld := fld.link + END; + IF offset > 2 THEN INC(offset, (-offset) MOD 4) END; + typ.size := offset; typ.align := 4; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + TypeSize(btyp); + typ.size := typ.n * btyp.size + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + TypeSize(btyp); + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END TypeSize; + +----------------------------------------------------- *) + + PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN); + VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER; + fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name; + BEGIN + IF typ.untagged THEN guarded := TRUE END; + IF typ = DevCPT.undftyp THEN DevCPM.err(58) + ELSIF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0; align := 1; + ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align + END ; + IF typ.sysflag = noAlign THEN alignLimit := 1 + ELSIF typ.sysflag = align2 THEN alignLimit := 2 + ELSIF typ.sysflag = align8 THEN alignLimit := 8 + ELSE alignLimit := 4 + END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; GTypeSize(btyp, guarded); + IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit) + ELSIF btyp.size >= 4 THEN falign := 4 + ELSIF btyp.size >= 2 THEN falign := 2 + ELSE falign := 1 + END; + IF typ.sysflag = union THEN + fld.adr := 0; + IF btyp.size > offset THEN offset := btyp.size END; + ELSE + Align(offset, falign); + fld.adr := offset; + IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size) + ELSE offset := 4; DevCPM.Mark(214, typ.txtpos) + END + END; + IF falign > align THEN align := falign END ; + fld := fld.link + END; +(* + IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 8; + fld.right := typ.link; typ.link := fld; + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 12; + typ.link.link := fld; typ.link.left := fld; + offset := interfaceSize; align := 4 + END; +*) + IF typ.sysflag <= 0 THEN align := 4 END; + typ.align := align; + IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END; + typ.size := offset; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + GTypeSize(btyp, guarded); + IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size + ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos) + END + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize; + IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + GTypeSize(btyp, guarded); + IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4 + ELSE + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END + END GTypeSize; + + PROCEDURE TypeSize*(typ: DevCPT.Struct); (* also called from DevCPT.InStruct for arrays *) + BEGIN + GTypeSize(typ, FALSE) + END TypeSize; + + PROCEDURE GetComKernel; + VAR name: DevCPT.Name; mod: DevCPT.Object; + BEGIN + IF addRef = NIL THEN + DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL); + DevCPT.topScope.name := DevCPT.NewName("$$"); + name := "AddRef"; DevCPT.Insert(name, addRef); + addRef.mode := XProc; + addRef.fprint := addRefFP; + addRef.fpdone := TRUE; + name := "Release"; DevCPT.Insert(name, release); + release.mode := XProc; + release.fprint := addRefFP; + release.fpdone := TRUE; + name := "Release2"; DevCPT.Insert(name, release2); + release2.mode := XProc; + release2.fprint := addRefFP; + release2.fpdone := TRUE; + name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler); + DevCPC486.intHandler.mode := XProc; + DevCPC486.intHandler.fprint := intHandlerFP; + DevCPC486.intHandler.fpdone := TRUE; + DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope; + INC(DevCPT.nofGmod); + DevCPT.CloseScope; + END + END GetComKernel; + + PROCEDURE EnumTProcs(rec: DevCPT.Struct); (* method numbers in declaration order *) + VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object; + BEGIN + IF rec.n = -1 THEN + rec.n := 0; btyp := rec.BaseTyp; + IF btyp # NIL THEN + EnumTProcs(btyp); rec.n := btyp.n; + END; + obj := rec.strobj.link; + WHILE obj # NIL DO + DevCPT.FindBaseField(obj.name^, rec, redef); + IF redef # NIL THEN obj.num := redef.num (*mthno*); + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END; + obj := obj.nlink + END + END + END EnumTProcs; + + PROCEDURE CountTProcs(rec: DevCPT.Struct); + VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name; + + PROCEDURE TProcs(obj: DevCPT.Object); (* obj.mnolev = 0, TProcs of base type already counted *) + VAR redef: DevCPT.Object; + BEGIN + IF obj # NIL THEN + TProcs(obj.left); + IF obj.mode = TProc THEN + DevCPT.FindBaseField(obj.name^, rec, redef); + (* obj.adr := 0 *) + IF redef # NIL THEN + obj.num := redef.num (*mthno*); + IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN + obj.num := numPreIntProc + comProc - 1 - obj.num + END; + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END + END ; + TProcs(obj.right) + END + END TProcs; + + BEGIN + IF rec.n = -1 THEN + comProc := 0; + IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END; + btyp := rec.BaseTyp; + IF btyp # NIL THEN + IF btyp.sysflag = interface THEN + EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n; + ELSE + CountTProcs(btyp); rec.n := btyp.n + END + END; + WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END; + IF (btyp # NIL) & (btyp.sysflag = interface) THEN + IF comProc > 0 THEN + name := "QueryInterface"; DevCPT.FindField(name, rec, m); + IF m.link.typ.sysflag = interface THEN + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr}; + m.nlink := query; query := m + END; + name := "AddRef"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef; + END; + name := "RELEASE"; + DevCPT.FindField(name, rec, rel); + IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END; + IF (comProc > 0) OR (rel # NIL) THEN + name := "Release"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; m.adr := -1; + IF rel # NIL THEN release2.used := TRUE; m.nlink := release2 + ELSE release.used := TRUE; m.nlink := release + END + END + END; + TProcs(rec.link); + END + END CountTProcs; + + PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object); + + PROCEDURE ^TProcedures(obj: DevCPT.Object); + + PROCEDURE TypeAlloc(typ: DevCPT.Struct); + VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF ~typ.allocated THEN (* not imported, not predefined, not allocated yet *) + typ.allocated := TRUE; + TypeSize(typ); + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF typ.sysflag = interface THEN + EnumTProcs(typ); + ELSE + CountTProcs(typ) + END; + IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END; + IF btyp # NIL THEN TypeAlloc(btyp) END; + IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + TypeAlloc(fld.typ); fld := fld.link + END; + TProcedures(typ.link) + ELSIF f = Pointer THEN + IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos) + ELSE TypeAlloc(btyp); + END + ELSIF f = ProcTyp THEN + TypeAlloc(btyp); + Parameters(typ.link, NIL) + ELSE (* c IN {Array, DynArr} *) + TypeAlloc(btyp); + IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END; + END + END + END TypeAlloc; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE Parameters(firstPar, proc: DevCPT.Object); + (* firstPar.mnolev = 0 *) + VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER; + BEGIN + padr := ParOff; par := firstPar; + WHILE par # NIL DO + typ := par.typ; TypeAlloc(typ); + par.adr := padr; + IF (par.mode = VarPar) & (typ.comp # DynArr) THEN + IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8) + ELSE INC(padr, 4) + END + ELSE + IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END; + INC(padr, typ.size); Align(padr, 4) + END; + par := par.link + END; + IF proc # NIL THEN + IF proc.mode = XProc THEN + INCL(proc.conval.setval, isCallback) + ELSIF (proc.mode = TProc) + & (proc.num >= numPreIntProc) + & (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ)) + THEN + INCL(proc.conval.setval, isCallback); + INCL(proc.conval.setval, isGuarded) + END; + IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END; + IF isGuarded IN proc.conval.setval THEN + GetComKernel; vadr := -24 + ELSE + vadr := 0; + IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END; + IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END + END; + proc.conval.intval := padr; proc.conval.intval2 := vadr; + END + END Parameters; + + PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER); + (* allocates only offsets, regs allocated in DevCPC486.Enter *) + VAR adr: INTEGER; typ: DevCPT.Struct; + BEGIN + adr := varSize; + WHILE var # NIL DO + typ := var.typ; TypeAlloc(typ); + DEC(adr, typ.size); NegAlign(adr, Base(typ, 4)); + var.adr := adr; + var := var.link + END; + NegAlign(adr, 4); varSize := adr + END Variables; + + PROCEDURE ^Objects(obj: DevCPT.Object); + + PROCEDURE Procedure(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR oldPos: INTEGER; + BEGIN + oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr; + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ; + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + DevCPM.errpos := oldPos + END Procedure; + + PROCEDURE TProcedures(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR par: DevCPT.Object; psize: INTEGER; + BEGIN + IF obj # NIL THEN + TProcedures(obj.left); + IF (obj.mode = TProc) & (obj.scope # NIL) THEN + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + END ; + TProcedures(obj.right) + END + END TProcedures; + + PROCEDURE Objects(obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + Objects(obj.left); + IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN + IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ); + ELSE Procedure(obj) + END + END ; + Objects(obj.right) + END + END Objects; + + PROCEDURE Allocate*; + VAR gvarSize: INTEGER; name: DevCPT.Name; + BEGIN + DevCPM.errpos := DevCPT.topScope.adr; (* text position of scope used if error *) + gvarSize := 0; + Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize; + Objects(DevCPT.topScope.right) + END Allocate; + + (************************) + + PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN; + BEGIN + WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO + CASE n1.class OF + | Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj + | Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval) + | Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END + | Nderef, Nguard: + | Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + | Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END + | Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + ELSE RETURN FALSE + END ; + n1 := n1.left; n2 := n2.left + END; + RETURN FALSE + END SameExp; + + PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER); + VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE; + BEGIN + used := {}; size := 0; + WHILE n # NIL DO + IF n.class # Ncomp THEN + Check(n.left, ux, sx); + Check(n.right, uy, sy) + END; + ux := ux + uy; sf := 0; + CASE n.class OF + | Nvar, Nvarpar: + IF (n.class = Nvarpar) OR (n.typ.comp = DynArr) OR + (n.obj.mnolev > 0) & + (DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END + | Nguard: sf := 2 + | Neguard, Nderef: sf := 1 + | Nindex: + IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END; + IF sx > 0 THEN INC(sy) END + | Nmop: + CASE n.subcl OF + | is, adr, typfn, minus, abs, cap, val: sf := 1 + | bit: sf := 2; INCL(ux, CX) + | conv: + IF n.typ.form = Int64 THEN sf := 2 + ELSIF ~(n.typ.form IN realSet) THEN sf := 1; + IF n.left.typ.form IN realSet THEN INCL(ux, AX) END + END + | odd, cc, not: + END + | Ndop: + f := n.left.typ.form; + IF f # Bool THEN + CASE n.subcl OF + | times: + sf := 1; + IF f = Int8 THEN INCL(ux, AX) END + | div, mod: + sf := 3; INCL(ux, AX); + IF f > Int8 THEN INCL(ux, DX) END + | eql..geq: + IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4 + ELSIF f IN realSet THEN INCL(ux, AX); sf := 1 + ELSE sf := 1 + END + | ash, lsh, rot: + IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END + | slash, plus, minus, msk, in, bit: + sf := 1 + | len: + IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3 + ELSE sf := 1 + END + | min, max: + sf := 1; + IF f IN realSet THEN INCL(ux, AX) END + | queryfn: + ux := ux + {CX, SI, DI}; sf := 4 + END; + IF sy > sx THEN INC(sx) ELSE INC(sy) END + END + | Nupto: + IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2 + ELSE sf := 3 + END; + INCL(ux, CX); INC(sx) + | Ncall, Ncomp: + sf := 10; ux := wreg + {float} + | Nfield, Nconst, Nproc, Ntype: + END; + used := used + ux; + IF sx > size THEN size := sx END; + IF sy > size THEN size := sy END; + IF sf > size THEN size := sf END; + n := n.link + END; + IF size > 10 THEN size := 10 END + END Check; + + PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET); + VAR ux, uy: SET; sx, sy: INTEGER; + BEGIN + Check(left, ux, sx); Check(right, uy, sy); + IF sy > sx THEN + expr(right, y, hy + stpy, ux + stpy * {AX, CX}); + expr(left, x, hx, stpx); + DevCPC486.Assert(y, hy, stpy) + ELSE + expr(left, x, hx + stpx, uy); + expr(right, y, hy, stpy); + DevCPC486.Assert(x, hx, stpx) + END; + END DualExp; + + PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET); + VAR y: DevCPL486.Item; rev: BOOLEAN; + BEGIN + DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk}); + IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN + DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSIF x.mode # Reg THEN + DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF y.mode # Reg THEN + DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END IntDOp; + + PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER; + BEGIN + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END; + IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN + expr(n.right, x, {}, ux + {mem, stk}); + expr(n.left, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSIF float IN uy THEN (* function calls in both operands *) + expr(n.left, y, {}, uy + {mem}); + expr(n.right, x, {}, {mem, stk}); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSE + expr(n.left, x, {}, uy + {mem, stk}); + expr(n.right, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, FALSE) + END + END FloatDOp; + + PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER; + BEGIN + CASE n.class OF + Nvar, Nvarpar: + obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0; + IF obj.typ.comp = DynArr THEN x.mode := VarPar END; + IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con + ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con + ELSE x.offset := 0; x.tmode := VarPar + END + | Nfield: + design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj) + | Nderef: + IF n.subcl # 0 THEN + expr(n.left, x, hint, stop); + IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END + ELSE + expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x) + END + | Nindex: + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF wreg - uy = {} THEN + expr(n.right, y, hint + stop, ux); + design(n.left, x, hint, stop); + IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END + ELSE + design(n.left, x, hint, stop + uy); + IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {}) + ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop) + END + END + | Nguard, Neguard: + IF n.typ.form = Pointer THEN + IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END + ELSE design(n.left, x, hint, stop) + END; + DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard) + | Nproc: + obj := n.obj; x.mode := obj.mode; x.obj := obj; + IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END + END; + x.typ := n.typ + END design; + + PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN; + BEGIN + IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN + WHILE x.class = Nindex DO x := x.left END; + IF x.class = Nderef THEN RETURN TRUE END + END; + RETURN FALSE + END IsAllocDynArr; + + PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN); + VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER; + BEGIN + Check(left, ux, sx); + expr(right, y, wreg - {SI} + ux, {}); + ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux); + IF useLen & IsAllocDynArr(left) THEN (* keep len descriptor *) + design(left, x, wreg - {CX}, {loaded}); + DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI}) + ELSE + expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con}); + DevCPC486.Load(ay, {}, wreg - {SI} + {con}); + DevCPC486.Free(ax); DevCPC486.Free(ay) + END StringOp; + + PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + BEGIN + IF n.class < Nconst THEN + design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop) + ELSE expr(n, x, hint, stop) + END + END AdrExpr; + + (* ---------- interface pointer reference counting ---------- *) + + PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN); + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN + IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN + IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END + ELSE FindPtrs(fld.typ, fld.adr + adr) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF DevCPC486.ContainsIPtrs(btyp) THEN + i := 0; + WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END + END + ELSIF typ.comp = DynArr THEN + IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END + END + END FindPtrs; + + BEGIN + FindPtrs(typ, 0) + END HandleIPtrs; + + PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface) + & ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall)) + END CountedPtr; + + PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET); + (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + BEGIN + expr(ny, y, {}, wreg - {SI} + {mem, stk}); + IF (ny.class # Nconst) & ~CountedPtr(ny) THEN + DevCPC486.IPAddRef(y, 0, TRUE) + END; + IF nx # NIL THEN + DevCPC486.Assert(y, {}, wreg - {SI} + ux); + expr(nx, x, wreg - {DI}, {loaded}); + IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN + DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0 + END; + DevCPC486.IPRelease(x, 0, TRUE, FALSE); + END + END IPAssign; + + PROCEDURE IPStructAssign (typ: DevCPT.Struct); + VAR x, y: DevCPL486.Item; + BEGIN + IF typ.comp = DynArr THEN DevCPM.err(270) END; + (* addresses in SI and DI *) + x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0; + y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0; + HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE) + END IPStructAssign; + + PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item); + BEGIN + expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0; + IF nx.typ.form = Comp THEN + HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE) + ELSE (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + END + END IPFree; + + (* unchanged val parameters allways counted because of aliasing problems REMOVED! *) + + PROCEDURE InitializeIPVars (proc: DevCPT.Object); + VAR x: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* changed value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE) + END; + obj := obj.link + END + END InitializeIPVars; + + PROCEDURE ReleaseIPVars (proc: DevCPT.Object); + VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + obj := proc.link; + WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO + obj := obj.link + END; + IF obj = NIL THEN + obj := proc.scope.scope; + WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END; + IF obj = NIL THEN RETURN END + END; + DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32); + DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32); + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE) + END; + obj := obj.link + END; + obj := proc.scope.scope; + WHILE obj # NIL DO (* local variables *) + IF obj.used THEN + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE); + END; + obj := obj.link + END; + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END + END ReleaseIPVars; + + PROCEDURE CompareIntTypes ( + typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER + ); + VAR x, y: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + local := DevCPL486.NewLbl; + typ := typ.BaseTyp; num := 0; + WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO + IF (typ.sysflag = interface) & (typ.ext # NIL) THEN + IF num > 0 THEN DevCPC486.JumpT(x, local) END; + DevCPC486.GuidFromString(typ.ext, y); + x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem}); + x := y; DevCPC486.GetAdr(x, wreg - {DI}, {}); + x := id; DevCPC486.CmpString(x, y, eql, FALSE); + INC(num) + END; + typ := typ.BaseTyp + END; + IF num > 0 THEN DevCPC486.JumpF(x, exit) END; + IF num > 1 THEN DevCPL486.SetLabel(local) END + END CompareIntTypes; + + PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object); + VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER; + BEGIN + nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl; + this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp; + id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer; + int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer; + DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0; + DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c); + unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp; + DevCPC486.Load(unk, {}, {}); + unk.mode := Ind; unk.offset := 8; + DevCPC486.Load(unk, {}, {}); + DevCPL486.GenComp(c, unk); + DevCPL486.GenJump(4, nil, TRUE); + DevCPL486.MakeReg(c, int.reg, Pointer); + DevCPL486.GenPush(c); + c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer; + DevCPL486.GenPush(c); + DevCPL486.GenPush(unk); + c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer; + DevCPL486.GenMove(c, unk); + unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer; + DevCPL486.GenCall(unk); + DevCPC486.Free(unk); + DevCPL486.GenJump(-1, end, FALSE); + DevCPL486.SetLabel(nil); + DevCPL486.MakeConst(c, 80004002H, Int32); (* E_NOINTERFACE *) + DevCPC486.Result(proc, c); + CompareIntTypes(typ, id, end, num); + IF num > 0 THEN + DevCPC486.Load(this, {}, {}); + DevCPC486.Assign(int, this); + DevCPC486.IPAddRef(this, 0, FALSE); + DevCPL486.MakeConst(c, 0, Int32); (* S_OK *) + DevCPC486.Result(proc, c); + END; + DevCPL486.SetLabel(end) + END InstallQueryInterface; + + (* -------------------- *) + + PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item); + VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN; + BEGIN + IF n # NIL THEN + ActualPar(n.link, fp.link, FALSE, ap); + niltest := FALSE; + IF fp.mode = VarPar THEN + IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN + expr(n.right, ap, {}, {}); DevCPC486.Push(ap); (* push type/length *) + expr(n.left, ap, {}, {}); DevCPC486.Push(ap); (* push adr *) + RETURN + ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN + IPFree(n, ap) + ELSE + x := n; + WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END; + niltest := x.class = Nderef; (* explicit nil test needed *) + AdrExpr(n, ap, {}, {}) + END + ELSIF (n.class = Nmop) & (n.subcl = conv) THEN + IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265) + ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form)) + & (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high}); + ELSE expr(n, ap, {}, {high}); + END + ELSE expr(n, ap, {}, {high}); + IF CountedPtr(n) THEN DevCPM.err(270) END + END; + DevCPC486.Param(fp, rec, niltest, ap, tag) + END + END ActualPar; + + PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE; + BEGIN + IF n.left.class = Nproc THEN + proc := n.left.obj; m := proc.mode; + ELSE proc := NIL; m := 0 + END; + IF (m = CProc) & (n.right # NIL) THEN + ActualPar(n.right.link, n.obj.link, FALSE, tag); + expr(n.right, tag, wreg - {AX}, {}); (* tag = first param *) + ELSE + IF proc # NIL THEN DevCPC486.PrepCall(proc) END; + ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag); + END; + IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END; + DevCPC486.Call(x, tag) + END Call; + + PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + VAR offset: INTEGER; + BEGIN + IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN + expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval; + IF n.subcl = minus THEN offset := -offset END + ELSE + expr(n, x, hint, stop + {mem}); offset := 0 + END; + DevCPC486.Mem(x, offset, typ) + END Mem; + + PROCEDURE^ CompStat (n: DevCPT.Node); + PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + + PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label); + VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct; + BEGIN + IF n.class = Nmop THEN + CASE n.subcl OF + not: condition(n.left, x, true, false); DevCPC486.Not(x) + | is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem}) + ELSE design(n.left, x, {}, {}) + END; + DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE) + | odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x) + | cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool + | val: DevCPM.err(220) + END + ELSIF n.class = Ndop THEN + CASE n.subcl OF + and: local := DevCPL486.NewLbl; condition(n.left, y, false, local); + DevCPC486.JumpF(y, false); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | or: local := DevCPL486.NewLbl; condition(n.left, y, local, true); + DevCPC486.JumpT(y, true); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | eql..geq: + f := n.left.typ.form; + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN {String8, String16, Comp} THEN + IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN (* converted must be source *) + StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE) + ELSE + StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE) + END + ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x) + ELSE + IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END; + DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk}); + IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END + | in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk}); + DevCPC486.In(x, y) + | bit: Check(n.left, ux, sx); + expr(n.right, x, {}, ux + {short}); + Mem(n.left, y, DevCPT.notyp, {}, {}); + DevCPC486.Load(x, {}, {short}); + DevCPC486.In(x, y) + | queryfn: + AdrExpr(n.right, x, {}, {CX, SI, DI}); + CompareIntTypes(n.left.typ, x, false, num); + IF num > 0 THEN + Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y); + x.offset := 1 (* true *) + ELSE x.offset := 0 (* false *) + END; + x.mode := Con; DevCPC486.MakeCond(x) + END + ELSIF n.class = Ncomp THEN + CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END + ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x) (* const, var, or call *) + END + END condition; + + PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label; + uy: SET; sy: INTEGER; r: REAL; + BEGIN + f := n.typ.form; + IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN + false := DevCPL486.NewLbl; true := DevCPL486.NewLbl; + condition(n, y, false, true); + DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem}) + ELSE + CASE n.class OF + Nconst: + IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END; + CASE f OF + Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f) + | Int64: + DevCPL486.MakeConst(x, cval.intval, f); + DevCPE.GetLongWords(cval, x.scale, x.offset) + | Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set) + | String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f) + | Comp: + ASSERT(n.typ = DevCPT.guidtyp); + IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x) + ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x) + END + END + | Nupto: (* n.typ = DevCPT.settyp *) + Check(n.right, uy, sy); + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {}); + DevCPC486.Assert(x, {}, uy); + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {}); + DevCPC486.Load(x, hint + stop, {}); + IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y + ELSE DevCPC486.IntDOp(x, y, msk, FALSE) + END + | Nmop: + CASE n.subcl OF + | bit: + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {}) + | conv: + IF f IN {String8, String16} THEN + expr(n.left, x, hint, stop); + IF f = String8 THEN x.form := VString16to8 END (* SHORT *) + ELSE + IF n.left.class = Nconst THEN (* largeint -> longreal *) + ASSERT((n.left.typ.form = Int64) & (f = Real64)); + DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form); + ELSE + expr(n.left, x, hint + stop, {high}); + END; + DevCPC486.Convert(x, f, -1, hint + stop, {}) (* ??? *) + END + | val: + expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop) (* ??? *) + | adr: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + ELSE + AdrExpr(n.left, x, hint + stop, {}); + END; + DevCPC486.GetAdr(x, hint + stop, {}) + | typfn: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + IF x.obj.typ.untagged THEN DevCPM.err(111) END + ELSE + expr(n.left, x, hint + stop, {}); + DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y + END; + DevCPC486.Load(x, hint + stop, {}) + | minus, abs, cap: + expr(n.left, x, hint + stop, {mem, stk}); + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl) + ELSE DevCPC486.IntMOp(x, n.subcl) + END + END + | Ndop: + IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN + IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN + expr(n.left, x, {}, {mem, stk}); + cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1; + WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END; + DevCPL486.AllocConst(y, cval, Real32); + DevCPC486.FloatDOp(x, y, times, FALSE) + ELSE FloatDOp(n, x) + END + ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {}) + ELSE + CASE n.subcl OF + times: + IF f = Int8 THEN + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk}); + DevCPC486.IntDOp(x, y, times, FALSE) + ELSE IntDOp(n, x, hint + stop) + END + | div, mod: + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk}); + DevCPC486.DivMod(x, y, n.subcl = mod) + | plus: + IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {}) + ELSE IntDOp(n, x, hint + stop) + END + | slash, minus, msk, min, max: + IntDOp(n, x, hint + stop) + | ash, lsh, rot: + uy := {}; IF n.right.class # Nconst THEN uy := {CX} END; + DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk}); + DevCPC486.Shift(x, y, n^.subcl) + | len: + IF n.left.typ.form IN {String8, String16} THEN + expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + DevCPC486.StrLen(x, n.left.typ, FALSE) + ELSE + design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y) + END + END + END + | Ncall: + Call(n, x) + | Ncomp: + CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END + ELSE + design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {}) (* ??? *) + END + END; + x.typ := n.typ; + DevCPC486.Assert(x, hint, stop) + END expr; + + PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN); + VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX}); + IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END; + expr(n, src, wreg - {SI}, {}); + adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con}); + IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END; + DevCPC486.Load(dadr, {}, wreg - {DI} + {con}); + DevCPC486.AddCopy(dest, src, last) + END AddCopy; + + PROCEDURE StringCopy (left, right: DevCPT.Node); + VAR x, y, ax, ay, len: DevCPL486.Item; + BEGIN + IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI}) (* keep len descriptor *) + ELSE expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI}); + DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {}); + WHILE right.class = Ndop DO + ASSERT(right.subcl = plus); + AddCopy(right.left, x, ax, len, FALSE); + right := right.right + END; + AddCopy(right, x, ax, len, TRUE); + DevCPC486.Free(len) + END StringCopy; + + PROCEDURE Checkpc; + BEGIN + DevCPE.OutSourceRef(DevCPM.errpos) + END Checkpc; + + PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + + PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label); + VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node; + BEGIN + local := DevCPL486.NewLbl; + DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left; + IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq) + & (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq) + & SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN (* reuse comparison *) + DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2) + ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is) + & SameExp(cond.left, last.left) THEN + DevCPC486.ShortTypTest(x, cond.obj.typ) (* !!! *) + ELSE condition(cond, x, else, local) + END; + hint := x.reg; + DevCPC486.JumpF(x, else); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + stat(if.right, end); + END CondStat; + + PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label); + VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER; + BEGIN (* n.class = Nifelse *) + if := n.left; last := NIL; + WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO + else := DevCPL486.NewLbl; + CondStat(if, last, hint, else, end); + IF sequential THEN DevCPC486.Jump(end) END; + DevCPL486.SetLabel(else); last := if.left; if := if.link + END; + IF n.right # NIL THEN stat(n.right, end) + ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE + ELSE CondStat(if, last, hint, end, end) + END + END IfStat; + + PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN); + VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER; + BEGIN + IF n # NIL THEN + this := SHORT(ENTIER(n.conval.realval)); + IF useTree IN n.conval.setval THEN + IF n.left # NIL THEN + IF n.right # NIL THEN + higher := DevCPL486.NewLbl; + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE); + CasePart(n.left, x, else, FALSE); + DevCPL486.SetLabel(higher); + CasePart(n.right, x, else, last) + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE); + CasePart(n.left, x, else, last); + END + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE); + IF n.right # NIL THEN CasePart(n.right, x, else, last) + ELSIF ~last THEN DevCPC486.Jump(else) + END + END + ELSE + IF useTable IN n.conval.setval THEN + m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval; + m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2; + DevCPC486.CaseTableJump(x, low, high, else); + actual := low; last := TRUE + END; + CasePart(n.left, x, else, FALSE); + WHILE actual < n.conval.intval DO + DevCPL486.GenCaseEntry(else, FALSE); INC(actual) + END; + WHILE actual < n.conval.intval2 DO + DevCPL486.GenCaseEntry(this, FALSE); INC(actual) + END; + DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual); + CasePart(n.right, x, else, last) + END; + n.conval.realval := this + END + END CasePart; + + PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label; + BEGIN + expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl; + IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN (* jump to goto optimization *) + CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x); + n.right.right.right.conval.intval2 := else; sequential := FALSE + ELSE + CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x); + DevCPL486.SetLabel(else); + IF n.right.conval.setval # {} THEN stat(n.right.right, end) + ELSE DevCPC486.Trap(caseTrap); sequential := FALSE + END + END; + case := n.right.left; + WHILE case # NIL DO (* case.class = Ncasedo *) + IF sequential THEN DevCPC486.Jump(end) END; + lab := case.left; + IF (case.right # NIL) & (case.right.class = Ngoto) THEN (* jump to goto optimization *) + case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval)); + ASSERT(lab.link = NIL); sequential := FALSE + ELSE + WHILE lab # NIL DO + this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link + END; + stat(case.right, end) + END; + case := case.link + END + END CaseStat; + + PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); + VAR len: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END; + expr(n, len, {}, {mem, short}); + IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END; + IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END; + DevCPC486.MulDim(len, nofel, fact, dimtyp); + IF n.link # NIL THEN + Dim(n.link, x, nofel, fact, dimtyp.BaseTyp); + ELSE + DevCPC486.New(x, nofel, fact) + END; + DevCPC486.SetDim(x, len, dimtyp) + END Dim; + + PROCEDURE CompStat (n: DevCPT.Node); + VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct; + BEGIN + Checkpc; + WHILE (n # NIL) & DevCPM.noerr DO + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF n.right.typ.form IN {String8, String16} THEN + StringCopy(n.left, n.right) + ELSE + IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN + IPAssign(NIL, n.right, x, y, {}); (* no Release *) + ELSE expr(n.right, y, {}, {}) + END; + expr(n.left, x, {}, {}); + DevCPC486.Assign(x, y) + END + ELSE ASSERT(n.subcl = newfn); + typ := n.left.typ.BaseTyp; + ASSERT(typ.comp = DynArr); + ASSERT(n.right.link = NIL); + expr(n.right, y, {}, wreg - {CX} + {mem, stk}); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPC486.CopyReg(sp, old, {}, {CX}); + DevCPC486.CopyReg(y, len, {}, {CX}); + IF typ.BaseTyp.form = Char16 THEN + DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE) + END; + DevCPC486.StackAlloc; + DevCPC486.Free(y); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp); + DevCPC486.Push(len); + DevCPC486.Push(old); + typ.sysflag := stackArray + END; + n := n.link + END + END CompStat; + + PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + VAR x, y, sp: DevCPL486.Item; + BEGIN + IF n.link # NIL THEN CompRelease(n.link, res) END; + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN + IF res.mode = Cond THEN + DevCPL486.GenCode(9CH); (* push flags *) + res.mode := Stk + ELSIF res.mode = Reg THEN + IF res.form < Int16 THEN DevCPC486.Push(res) + ELSE DevCPC486.Assert(res, {}, {AX, CX, DX}) + END + END; + expr(n.left, x, wreg - {DI}, {loaded}); + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + n.left.obj.used := FALSE + END + ELSE ASSERT(n.subcl = newfn); + DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp); + DevCPL486.MakeConst(y, 0, Pointer); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + END + END CompRelease; + + PROCEDURE Assign(n: DevCPT.Node; ux: SET); + VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER; + BEGIN + r := n.right; f := r.typ.form; uf := {}; + IF (r.class IN {Nmop, Ndop}) THEN + IF (r.subcl = conv) & (f # Set) & +(* + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left; + IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *) +*) + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) & + ((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left + ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN + IF r.class = Ndop THEN + IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN + expr(r.right, y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE); + RETURN + ELSIF r.subcl IN {ash, lsh, rot} THEN + expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl); + RETURN + END + ELSE + IF r.subcl IN {minus, abs, cap} THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN + END + END + ELSIF f = Bool THEN + IF (r.subcl = not) & SameExp(n.left, r.left) THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN + END + END + END; + IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux) + ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded}); (* high ??? *) + END; + DevCPC486.Assign(x, y) + END Assign; + + PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET; + BEGIN + sequential := TRUE; INC(nesting); + WHILE (n # NIL) & DevCPM.noerr DO + IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END; + DevCPM.errpos := n.conval.intval; DevCPL486.BegStat; + CASE n.class OF + | Ninittd: + (* done at load-time *) + | Nassign: + Checkpc; + Check(n.left, ux, sx); + CASE n.subcl OF + assign: + IF n.left.typ.form = Comp THEN + IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN + StringCopy(n.left, n.right) + ELSE + StringOp(n.left, n.right, x, y, TRUE); + IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END; + DevCPC486.Copy(x, y, FALSE) + END + ELSE Assign(n, ux) + END + | getfn: + Mem(n.right, y, n.left.typ, {}, ux); + expr(n.left, x, {}, {loaded}); + DevCPC486.Assign(x, y) + | putfn: + expr(n.right, y, {}, ux); + Mem(n.left, x, n.right.typ, {}, {}); + DevCPC486.Assign(x, y) + | incfn, decfn: + expr(n.right, y, {}, ux); expr(n.left, x, {}, {}); + IF n.left.typ.form = Int64 THEN + DevCPC486.LargeInc(x, y, n.subcl = decfn) + ELSE + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE) + END + | inclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE) + | exclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE) + | getrfn: + expr(n.right, y, {}, {}); + IF y.offset < 8 THEN + DevCPL486.MakeReg(y, y.offset, n.left.typ.form); (* ??? *) + expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | putrfn: + expr(n.left, x, {}, {}); + IF x.offset < 8 THEN + DevCPL486.MakeReg(x, x.offset, n.right.typ.form); (* ??? *) + expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | newfn: + y.typ := n.left.typ; + IF n.right # NIL THEN + IF y.typ.BaseTyp.comp = Record THEN + expr(n.right, nofel, {}, {AX, CX, DX, mem, stk}); + DevCPC486.New(y, nofel, 1); + ELSE (*open array*) + nofel.mode := Con; nofel.form := Int32; fact := 1; + Dim(n.right, y, nofel, fact, y.typ.BaseTyp) + END + ELSE + DevCPL486.MakeConst(nofel, 0, Int32); + DevCPC486.New(y, nofel, 1); + END; + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + | sysnewfn: + expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + | copyfn: + StringOp(n.left, n.right, x, y, TRUE); + DevCPC486.Copy(x, y, TRUE) + | movefn: + Check(n.right.link, uz, sz); + expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz); + expr(n.left, x, {}, wreg - {DI} + {short} + uz); + expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short}); + DevCPC486.Load(x, {}, wreg - {DI} + {con}); + DevCPC486.Load(y, {}, wreg - {SI} + {con}); + DevCPC486.SysMove(nofel) + END; + sequential := TRUE + | Ncall: + Checkpc; + Call(n, x); sequential := TRUE + | Nifelse: + IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END + | Ncase: + Checkpc; + CaseStat(n, next) + | Nwhile: + local := DevCPL486.NewLbl; + IF n.right # NIL THEN DevCPC486.Jump(local) END; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + stat(n.right, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE + | Nrepeat: + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE + | Nloop: + prevExit := Exit; Exit := next; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop); + IF sequential THEN DevCPC486.Jump(loop) END; + next := Exit; Exit := prevExit; sequential := FALSE + | Nexit: + Checkpc; + DevCPC486.Jump(Exit); sequential := FALSE + | Nreturn: + IF n.left # NIL THEN + Checkpc; + IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer) + & (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {}) + ELSE expr(n.left, x, wreg - {AX}, {}) + END; + DevCPC486.Result(n.obj, x) + END; + IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END; + sequential := FALSE + | Nwith: + IfStat(n, n.subcl = 0, next) + | Ntrap: + Checkpc; + DevCPC486.Trap(n.right.conval.intval); sequential := TRUE + | Ncomp: + CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x) + | Ndrop: + Checkpc; + expr(n.left, x, {}, {}); DevCPC486.Free(x) + | Ngoto: + IF n.left # NIL THEN + Checkpc; + condition(n.left, x, next, n.right.conval.intval2); + DevCPC486.JumpT(x, n.right.conval.intval2) + ELSE + DevCPC486.Jump(n.right.conval.intval2); + sequential := FALSE + END + | Njsr: + DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE) (* call n.right *) + | Nret: + DevCPL486.GenReturn(0); sequential := FALSE (* ret 0 *) + | Nlabel: + DevCPL486.SetLabel(n.conval.intval2) + END; + DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link; + IF n = NIL THEN end := next + ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next) + END + END; + DEC(nesting) + END stat; + + PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN); + BEGIN + WHILE n # NIL DO + IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END; + CASE n.class OF + | Ncase: + CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu) + | Ncasedo: + CheckFpu(n.right, useFpu) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + CheckFpu(n.left, useFpu) + | Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END CheckFpu; + + PROCEDURE procs(n: DevCPT.Node); + VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label; + ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN; + BEGIN + INC(DevCPL486.level); nesting := 0; + WHILE (n # NIL) & DevCPM.noerr DO + DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj; + IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END; + procs(n.left); + DevCPM.errpos := n.conval.intval; + useFpu := FALSE; CheckFpu(n.right, useFpu); + DevCPC486.Enter(proc, n.right = NIL, useFpu); + InitializeIPVars(proc); + end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end); + DevCPM.errpos := n.conval.intval2; Checkpc; + IF sequential OR (end # DevCPL486.NewLbl) THEN + DevCPL486.SetLabel(end); + IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END + END; + DevCPL486.SetLabel(Return); + ReleaseIPVars(proc); + DevCPC486.Exit(proc, n.right = NIL); + IF proc.mode = TProc THEN + name := proc.link.typ.strobj.name^$; i := 0; + WHILE name[i] # 0X DO INC(i) END; + name[i] := "."; INC(i); j := 0; ch := proc.name[0]; + WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ; + name[i] := 0X; + ELSE name := proc.name^$ + END; + DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right); + n := n.link + END; + DEC(DevCPL486.level) + END procs; + + PROCEDURE Module*(prog: DevCPT.Node); + VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node; + aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN; + BEGIN + DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop}); + DevCPM.NewObj(DevCPT.SelfName); + IF DevCPM.noerr THEN + DevCPE.OutHeader; n := prog.right; + WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END; + useFpu := FALSE; CheckFpu(n, useFpu); + DevCPC486.Enter(NIL, n = NIL, useFpu); + end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end); + DevCPM.errpos := prog.conval.intval2; Checkpc; + DevCPC486.Exit(NIL, n = NIL); + IF prog.link # NIL THEN (* close section *) + DevCPL486.SetLabel(DevCPE.closeLbl); + useFpu := FALSE; CheckFpu(prog.link, useFpu); + DevCPC486.Enter(NIL, FALSE, useFpu); + end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end); + DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc; + DevCPC486.Exit(NIL, FALSE) + END; + name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right); + DevCPM.errpos := prog.conval.intval; + WHILE query # NIL DO + typ := query.typ; query.typ := DevCPT.int32typ; + query.conval.intval := 20; (* parameters *) + query.conval.intval2 := -8; (* saved registers *) + DevCPC486.Enter(query, FALSE, FALSE); + InstallQueryInterface(typ, query); + DevCPC486.Exit(query, FALSE); + name := "QueryInterface"; DevCPE.OutRefName(name); + query := query.nlink + END; + procs(prog.left); + DevCPC486.InstallStackAlloc; + addRef := NIL; release := NIL; release2 := NIL; + DevCPC486.intHandler := NIL; + IF DevCPM.noerr THEN DevCPE.OutCode END; + IF ~DevCPM.noerr THEN DevCPM.DeleteObj END + END + END Module; + +END Dev0CPV486. diff --git a/Trurl-based/Dev0/Mod/Compiler.odc b/Trurl-based/Dev0/Mod/Compiler.odc new file mode 100644 index 0000000..8449f33 Binary files /dev/null and b/Trurl-based/Dev0/Mod/Compiler.odc differ diff --git a/Trurl-based/Dev0/Mod/Compiler.txt b/Trurl-based/Dev0/Mod/Compiler.txt new file mode 100644 index 0000000..26b638f --- /dev/null +++ b/Trurl-based/Dev0/Mod/Compiler.txt @@ -0,0 +1,140 @@ +MODULE Dev0Compiler; + + (* THIS IS TEXT COPY OF Compiler.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.10 + + Based on DevCompiler + *) + + IMPORT Files, Console, Kernel, Strings, + DevCPM := Dev0CPM, DevCPT:= Dev0CPT, DevCPB := Dev0CPB, DevCPP := Dev0CPP, + DevCPE := Dev0CPE, DevCPV := Dev0CPV486; + + CONST + (* compiler options: *) + checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; srcpos = 6; reallib = 7; signatures = 8; + hint = 29; oberon = 30; errorTrap = 31; + defopt = {checks, assert, obj, ref, allref, srcpos, signatures}; + + PROCEDURE WriteInt (x: INTEGER); + VAR s: ARRAY 16 OF CHAR; + BEGIN + Strings.IntToString(x, s); + Console.WriteStr(s) + END WriteInt; + + PROCEDURE Module (source: Files.Reader; opt: SET; VAR error: BOOLEAN); + VAR ext, new: BOOLEAN; p: DevCPT.Node; + i: INTEGER; + BEGIN + DevCPM.Init(source); + (* IF found THEN INCL(DevCPM.options, DevCPM.comAware) END; *) + IF errorTrap IN opt THEN INCL(DevCPM.options, DevCPM.trap) END; + IF oberon IN opt THEN INCL(DevCPM.options, DevCPM.oberon) END; + DevCPT.Init(opt); + DevCPB.typSize := DevCPV.TypeSize; + DevCPT.processor := DevCPV.processor; + DevCPP.Module(p); + IF DevCPM.noerr THEN + IF DevCPT.libName # "" THEN EXCL(opt, obj) END; +(* + IF errorTrap IN opt THEN DevCPDump.DumpTree(p) END; +*) + DevCPV.Init(opt); DevCPV.Allocate; DevCPT.Export(ext, new); + IF DevCPM.noerr & (obj IN opt) THEN + DevCPV.Module(p) + END; + DevCPV.Close + END; + IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym + ELSE DevCPM.DeleteNewSym + END; + DevCPT.Close; + error := ~DevCPM.noerr; + DevCPM.Close; + p := NIL; + Kernel.FastCollect; + IF error THEN + IF DevCPM.errors = 1 THEN + Console.WriteStr("one error detected") + ELSE + WriteInt(DevCPM.errors); Console.WriteStr(" errors detected") + END; + Console.WriteLn; + i := 0; + WHILE i < DevCPM.errors DO + Console.WriteStr(" pos = "); WriteInt(DevCPM.errPos[i]); Console.WriteStr(" err = "); + WriteInt(DevCPM.errNo[i]); Console.WriteLn; + INC(i) + END + ELSE + Console.WriteStr(" "); WriteInt(DevCPE.pc); Console.WriteStr(" "); WriteInt(DevCPE.dsize) + END; + Console.WriteLn + END Module; + + PROCEDURE Do (IN path, name: ARRAY OF CHAR; opt: SET); + VAR loc: Files.Locator; + f: Files.File; r: Files.Reader; error: BOOLEAN; + BEGIN + loc := Files.dir.This(path); + IF loc # NIL THEN + f := Files.dir.Old(loc, name$, FALSE); + IF f # NIL THEN + r := f.NewReader(NIL); + Module(r, opt, error); + IF error THEN Console.WriteStr("error(s)"); Console.WriteLn END; + f.Close + ELSE + Console.WriteStr("file not found: "); + Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name); Console.WriteLn + END + ELSE + Console.WriteStr("path not found: "); + Console.WriteStr(path); Console.WriteLn + END + END Do; + + PROCEDURE Compile* (IN path, name: ARRAY OF CHAR); + BEGIN + Console.WriteStr("compiling "); + Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name); + Console.WriteLn; + Do(path, name, defopt) + END Compile; + + PROCEDURE CompileOpt* (IN path, name: ARRAY OF CHAR; IN opt: ARRAY OF CHAR); + VAR loc: Files.Locator; + f: Files.File; r: Files.Reader; error: BOOLEAN; i: INTEGER; opts: SET; + BEGIN + i := 0; opts := defopt; + WHILE opt[i] # 0X DO + IF opt[i] = "-" THEN + IF srcpos IN opts THEN EXCL(opts, srcpos) + ELSIF allref IN opts THEN EXCL(opts, allref) + ELSIF ref IN opts THEN EXCL(opts, ref) + ELSE EXCL(opts, obj) + END + ELSIF opt[i] = "!" THEN + IF assert IN opts THEN EXCL(opts, assert) + ELSE EXCL(opts, checks) + END + ELSIF opt[i] = "+" THEN INCL(opts, allchecks) + ELSIF opt[i] = "?" THEN INCL(opts, hint) + ELSIF opt[i] = "@" THEN INCL(opts, errorTrap) + ELSIF opt[i] = "$" THEN INCL(opts, oberon) + END; + INC(i) + END; + + Console.WriteStr("compiling "); + Console.WriteStr(path); Console.WriteStr(" "); Console.WriteStr(name); + IF opt # "" THEN Console.WriteStr(" "); Console.WriteStr(opt); END; + Console.WriteLn; + Do(path, name, opts) + END CompileOpt; + +END Dev0Compiler. diff --git a/Trurl-based/Dev0/Mod/ElfLinker16.odc b/Trurl-based/Dev0/Mod/ElfLinker16.odc new file mode 100644 index 0000000..0b74d87 Binary files /dev/null and b/Trurl-based/Dev0/Mod/ElfLinker16.odc differ diff --git a/Trurl-based/Dev0/Mod/ElfLinker16.txt b/Trurl-based/Dev0/Mod/ElfLinker16.txt new file mode 100644 index 0000000..808804a --- /dev/null +++ b/Trurl-based/Dev0/Mod/ElfLinker16.txt @@ -0,0 +1,1892 @@ +MODULE Dev0ElfLinker; + + (* THIS IS TEXT COPY OF ElfLinker16.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + changes = "" + issues = "" + +**) + +(* + DevElfLinker version compatible with BlackBox Component Builder release 1.6. + This module will replace DevElfLinker, once the final version of BlackBox 1.6 will be released. +*) + +(* + A. V. Shiryaev, 2012.09 + + Based on DevElfLinker16; modified to not depend on TextModels (TextModels -> Console) +*) + + IMPORT + Strings, + Kernel, Files, (* Dialog, TextMappers, StdLog, DevCommanders *) Console; + + CONST + NewRecFP = 4E27A847H; + NewArrFP = 76068C78H; + + OFdir = "Code"; + SYSdir = "System"; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; + mInternal = 1; mExported = 4; + + (* mod desc fields *) + modOpts = 4; modRefcnt = 8; modTerm = 40; modNames = 84; modImports = 92; modExports = 96; + + (* .dynsym entries *) + stbLocal = 0; stbGlobal = 1; + sttNotype = 0; sttObject = 1; sttFunc = 2; sttSection = 3; + shnUnd = 0; shnAbs = 0FFF1H; + + fixup = 0; + noSymbol = MIN(INTEGER); + noAddr = MIN(INTEGER); + firstDllSymbolVal = 12; + + (* distinguished section header indexes. *) + textIndexVal = 1; (* index of the .text section header in the section header table *) + rodataIndexVal = 3; (* index of the .rodata section header in the section header table *) + dynsymIndexVal = 5; (* index of the .dynsym section header in the section header table *) + dynstrIndexVal = 6; (* index of the .dynstr section header in the section header table *) + + (* fixed elements dimensions *) + elfHeaderSizeVal = 52; (* size of the ELF file header *) + shEntrySizeVal = 40; (* size of an entry in the section header table *) + dynsymEntrySizeVal = 16; (* size of a symbol table entry *) + dynamicEntrySizeVal = 8; (* size of an entry in the dynamic section *) + gotEntrySizeVal = 4; (* size of an entry in the got section *) + relEntrySizeVal = 8; (* size of an entry in a relocation section *) + phEntrySizeVal = 32; (* size of an entry in the program header *) + + shNumVal = 12; (* number of entries in the section header table. See WriteSectionHeaderTable *) + shStrndxVal = shNumVal - 1; (* index of the string table for section names. See WriteSectionHeaderTable *) + phNumVal = 3; (* number of entries in the program header table *) + + (* sections alignments (in bytes) *) + textAlign = 4H; + dynsymAlign = 4H; + dynstrAlign = 1H; + hashAlign = 4H; + gotAlign = 4H; + dynamicAlign = 4H; + shstrtabAlign = 1H; + bssAlign = 4H; + rodataAlign = 8H; + relAlign = 4H; + + pageSize = 1000H; (* I386 page size *) + + r38632 = 1; r386pc32 = 2; r386Relative = 8; (* ELF relocation types *) + + + (* A. V. Shiryaev: Scanner *) + TMChar = 0; TMString = 1; TMEOT = 2; + + TYPE + Name = ARRAY 40 OF SHORTCHAR; + + Export = POINTER TO RECORD + next: Export; + name: Name; + adr: INTEGER + END; + + Module = POINTER TO RECORD + next: Module; + name: Name; + fileName: Files.Name; + file: Files.File; + hs, ms, ds, cs, vs, ni, ma, ca, va: INTEGER; + dll, intf: BOOLEAN; + exp: Export; + imp: POINTER TO ARRAY OF Module; + data: POINTER TO ARRAY OF BYTE + END; + + Strtab = RECORD + tab: ARRAY 4096 OF SHORTCHAR; + cur: INTEGER + END; + + Relocation = RECORD + offset, type: INTEGER + END; + + RelTab = RECORD + tab: ARRAY 65536 OF Relocation; + cur: INTEGER + END; + + Section = RECORD + fileOffset, + memOffset, + size: INTEGER + END; + + (* A. V. Shiryaev: Scanner *) + ScanRider = RECORD + s: POINTER TO ARRAY OF CHAR; + i: INTEGER + END; + Scanner = RECORD + rider: ScanRider; + start, type: INTEGER; + + string: ARRAY 100 OF CHAR; + char: CHAR + END; + + VAR + Out: Files.File; + R: Files.Reader; + Ro: Files.Writer; + error, isDll, isStatic: BOOLEAN; + modList, kernel, main, last, impg, impd: Module; + numMod, lastTerm: INTEGER; + firstExp, lastExp: Export; + CodeSize, DataSize, ConSize: INTEGER; + maxCode, numExp: INTEGER; + newRec, newArr: Name; + code: POINTER TO ARRAY OF BYTE; + + (* fixup positions *) + entryPos, + expPos, + shstrtabPos, + finiPos: INTEGER; + + (* sections *) + text, reltext, relrodata, rodata, dynstr, shstrtab, hash, got, dynsym, dynamic, bss: Section; + + (* distinguished file and memory offsets *) + shOffsetVal, (* section header table file offset *) + phOffsetVal, (* program header table file offset *) + finiMemOffsetVal: INTEGER; (* memory offset (aka virtual address) of the finalization code (CLOSE sections) *) + + dynsymInfoVal, (* value of the info field for the .dynsym section *) + sonameStrIndexVal: INTEGER; (* string table index of the name of hte library *) + + (* segment dimensions *) + textSegmentSizeVal, + dataSegmentSizeVal, + dynamicSegmentSizeVal: INTEGER; + + headerstrtab, dynstrtab: Strtab; + hashtab: ARRAY 256 OF Name; + + neededIdx: ARRAY 256 OF INTEGER; + + relTextTab, relRodataTab: RelTab; + + soName: Name; + + doWrite: BOOLEAN; + + PROCEDURE (VAR t: Strtab) AddName (IN s: ARRAY OF SHORTCHAR; OUT idx: INTEGER), NEW; + VAR i: INTEGER; + BEGIN + ASSERT((t.cur + LEN(s$)) <= LEN(t.tab), 20); (* table buffer not large enough: TODO enlarge? *) + idx := t.cur; + i := 0; + WHILE s[i] # 0X DO + t.tab[t.cur] := s[i]; + INC(i); INC(t.cur) + END; + t.tab[t.cur] := s[i]; (* copy the 0X *) + INC(t.cur) + END AddName; + + PROCEDURE (VAR t: RelTab) Add (offset, type: INTEGER), NEW; + BEGIN + ASSERT(t.cur < LEN(t.tab), 20); (* table buffer not large enough: TODO enlarge? *) + t.tab[t.cur].offset := offset; + t.tab[t.cur].type := type; + INC(t.cur) + END Add; + + PROCEDURE AddNeededIdx (idx: INTEGER); + VAR i, len: INTEGER; + BEGIN + ASSERT(idx > 0, 20); (* index must be positive *) + len := LEN(neededIdx); + i := 0; + WHILE (i # len) & (neededIdx[i] # 0) DO INC(i) END; + IF i # len THEN + neededIdx[i] := idx + ELSE + HALT(21) (* no more space for indexes *) + END + END AddNeededIdx; + + (* A. V. Shiryaev: Console *) + + PROCEDURE WriteString (s: ARRAY OF CHAR); + BEGIN + Console.WriteStr(s) + END WriteString; + + PROCEDURE WriteChar (c: CHAR); + VAR s: ARRAY 2 OF CHAR; + BEGIN + s[0] := c; s[1] := 0X; + Console.WriteStr(s) + END WriteChar; + + PROCEDURE WriteSString (ss: ARRAY OF SHORTCHAR); + BEGIN + Console.WriteStr(ss$) + END WriteSString; + + PROCEDURE WriteInt (x: INTEGER); + VAR s: ARRAY 16 OF CHAR; + BEGIN + Strings.IntToString(x, s); + Console.WriteStr(s) + END WriteInt; + + PROCEDURE WriteLn; + BEGIN + Console.WriteLn + END WriteLn; + + PROCEDURE FlushW; + BEGIN + END FlushW; + + PROCEDURE ThisFile (modname: ARRAY OF CHAR): Files.File; + VAR dir, name: Files.Name; loc: Files.Locator; f: Files.File; + BEGIN + Kernel.SplitName(modname, dir, name); + Kernel.MakeFileName(name, Kernel.objType); + loc := Files.dir.This(dir); loc := loc.This(OFdir); + f := Files.dir.Old(loc, name, TRUE); + IF (f = NIL) & (dir = "") THEN + loc := Files.dir.This(SYSdir); loc := loc.This(OFdir); + f := Files.dir.Old(loc, name, TRUE) + END; + RETURN f + END ThisFile; + + PROCEDURE Read4 (VAR x: INTEGER); + VAR b: BYTE; + BEGIN + R.ReadByte(b); x := b MOD 256; + R.ReadByte(b); x := x + 100H * (b MOD 256); + R.ReadByte(b); x := x + 10000H * (b MOD 256); + R.ReadByte(b); x := x + 1000000H * b + END Read4; + + PROCEDURE ReadName (VAR name: ARRAY OF SHORTCHAR); + VAR i: INTEGER; b: BYTE; + BEGIN i := 0; + REPEAT + R.ReadByte(b); name[i] := SHORT(CHR(b)); INC(i) + UNTIL b = 0 + END ReadName; + + PROCEDURE RNum (VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; R.ReadByte(b); + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); R.ReadByte(b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y + END RNum; + + PROCEDURE WriteCh (ch: SHORTCHAR); + BEGIN + IF doWrite THEN + Ro.WriteByte(SHORT(ORD(ch))) + END + END WriteCh; + + PROCEDURE Write2 (x: INTEGER); + BEGIN + IF doWrite THEN + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))) + END + END Write2; + + PROCEDURE Write4 (x: INTEGER); + BEGIN + IF doWrite THEN + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))) + END + END Write4; + + PROCEDURE WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER); + BEGIN + IF doWrite THEN + Ro.WriteBytes(x, beg, len) + END + END WriteBytes; + + PROCEDURE Align (alignment: INTEGER); + BEGIN + WHILE Ro.Pos() MOD alignment # 0 DO WriteCh(0X) END + END Align; + + PROCEDURE Aligned (pos, alignment: INTEGER): INTEGER; + BEGIN + RETURN (pos + (alignment - 1)) DIV alignment * alignment + END Aligned; + + PROCEDURE Put (mod: Module; a, x: INTEGER); + BEGIN + ASSERT((mod.data # NIL) & ((a >= 0) & (a <= LEN(mod.data))), 20); + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)) + END Put; + + PROCEDURE Get (mod: Module; a: INTEGER; VAR x: INTEGER); + BEGIN + ASSERT((mod.data # NIL) & ((a >= 0) & (a + 3 <= LEN(mod.data))), 20); + x := ((mod.data[a + 3] * 256 + + (mod.data[a + 2] MOD 256)) * 256 + + (mod.data[a + 1] MOD 256)) * 256 + + (mod.data[a] MOD 256) + END Get; + + PROCEDURE CheckDllImports (mod: Module); + VAR i, x, y: INTEGER; name: Name; imp: Module; exp: Export; + + PROCEDURE SkipLink; + VAR a: INTEGER; + BEGIN + RNum(a); + WHILE a # 0 DO RNum(a); RNum(a) END + END SkipLink; + + BEGIN + R := mod.file.NewReader(R); + R.SetPos(mod.hs + mod.ms + mod.ds + mod.cs); + SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; + i := 0; + WHILE i < mod.ni DO + imp := mod.imp[i]; + IF imp # NIL THEN + RNum(x); + WHILE x # 0 DO + ReadName(name); RNum(y); + IF x = mVar THEN + SkipLink; + IF imp.dll THEN + exp := imp.exp; + WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END; + IF exp = NIL THEN + NEW(exp); exp.name := name$; + exp.next := imp.exp; imp.exp := exp + END + END + ELSIF x = mTyp THEN RNum(y); + IF imp.dll THEN + RNum(y); + IF y # 0 THEN + WriteString("type descriptor ("); + WriteString(imp.name$); WriteChar("."); + WriteSString(name); + WriteString(") imported from DLL in "); + WriteString(mod.name$); + WriteLn; FlushW; error := TRUE; + RETURN + END + ELSE SkipLink + END + ELSIF x = mProc THEN + IF imp.dll THEN + SkipLink; + exp := imp.exp; + WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END; + IF exp = NIL THEN + NEW(exp); exp.name := name$; + exp.next := imp.exp; imp.exp := exp + END + END + END; + RNum(x) + END + END; + INC(i) + END + END CheckDllImports; + + PROCEDURE ReadHeaders; + VAR mod, im, t: Module; x, i, pos: INTEGER; impdll: BOOLEAN; name: Name; + BEGIN + ASSERT(isDll, 126); + mod := modList; modList := NIL; numMod := 0; + WHILE mod # NIL DO (* reverse mod list & count modules *) + IF ~mod.dll THEN INC(numMod) END; + t := mod; mod := t.next; t.next := modList; modList := t + END; + IF isStatic THEN + CodeSize := + 6 + 5 * numMod + 2 (* _init() *) + + 1 + 5 * numMod + 2 (* _fini() *) + ELSE + CodeSize := + 6 + 5 + 2 (* _init() *) + + 1 + 5 + 2 (* _fini() *) + END; + DataSize := 0; ConSize := 0; + maxCode := 0; numExp := 0; + mod := modList; + WHILE mod # NIL DO + IF ~mod.dll THEN + mod.file := ThisFile(mod.fileName); + IF mod.file # NIL THEN + R := mod.file.NewReader(R); R.SetPos(0); + Read4(x); + IF x = 6F4F4346H THEN + Read4(x); + Read4(mod.hs); Read4(mod.ms); Read4(mod.ds); Read4(mod.cs); + Read4(mod.vs); RNum(mod.ni); ReadName(mod.name); impdll := FALSE; + IF mod.ni > 0 THEN + NEW(mod.imp, mod.ni); + x := 0; + WHILE x < mod.ni DO + ReadName(name); + IF name = "$$" THEN + IF (mod # kernel) & (kernel # NIL) THEN + mod.imp[x] := kernel + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; error := TRUE + END + ELSIF name[0] = "$" THEN + (* StdLog.String(name$); *) + Console.WriteStr(name$); + i := 1; + WHILE name[i] # 0X DO name[i-1] := name[i]; INC(i) END; + name[i-1] := 0X; + IF i # 1 THEN + Strings.Find(name$, ".so", 0, pos); + IF pos = -1 THEN + name[i - 1] := "."; name[i] := "s"; name[i + 1] := "o"; name[i + 2] := 0X + END + END; + (* StdLog.String(" "); StdLog.String(name$); StdLog.Ln; *) + Console.WriteStr(" "); Console.WriteStr(name$); Console.WriteLn; + impdll := TRUE; im := modList; + WHILE (im # mod) & (im.name # name) DO im := im.next END; + IF (im = NIL) OR ~im.dll THEN + NEW(im); im.next := modList; modList := im; + im.dll := TRUE; + im.name := name$; + dynstrtab.AddName(name, i); + AddNeededIdx(i) + END; + mod.imp[x] := im + ELSE + im := modList; + WHILE (im # mod) & (im.name # name) DO im := im.next END; + IF im # mod THEN + mod.imp[x] := im + ELSE + WriteSString(name); + WriteString(" not present (imported in "); + WriteString(mod.name$); WriteChar(")"); + WriteLn; FlushW; error := TRUE + END + END; + INC(x) + END + END; + IF impdll & ~error THEN CheckDllImports(mod) END; + mod.ma := ConSize; INC(ConSize, mod.ms + mod.ds); + mod.va := DataSize; INC(DataSize, mod.vs); + mod.ca := CodeSize; INC(CodeSize, mod.cs); + IF mod.cs > maxCode THEN maxCode := mod.cs END + ELSE + WriteString(mod.name$); WriteString(": wrong file type"); + WriteLn; FlushW; error := TRUE + END; + mod.file.Close; mod.file := NIL + ELSE + WriteString(mod.fileName$ (* A. V. Shiryaev *)); WriteString(" not found"); + WriteLn; FlushW; error := TRUE + END; + last := mod + END; + mod := mod.next + END; + IF ~isStatic & (main = NIL) THEN + WriteSString("no main module specified"); WriteLn; + FlushW; error := TRUE + END; + IF DataSize = 0 THEN DataSize := 1 END + END ReadHeaders; + + PROCEDURE WriteElfHeader; + BEGIN + ASSERT(Ro.Pos() = 0, 100); + dynstrtab.AddName(soName$, sonameStrIndexVal); + Write4(464C457FH); Write4(00010101H); Write4(0); Write4(0); (* Magic *) + Write2(3); (* ET_DYN e_type Object file type *) + Write2(3); (* EM_386 e_machine Architecture *) + Write4(1); (* EV_CURRENT e_version Object file version *) + Write4(text.memOffset); (* e_entry Entry point virtual address *) + entryPos := Ro.Pos(); + Write4(fixup); (* e_phoff Program header table file offset *) + Write4(fixup); (* e_shoff: Section header table file offset *) + Write4(0); (* e_flags Processor-specific flags *) + Write2(elfHeaderSizeVal); (* e_ehsize ELF header size in bytes *) + Write2(phEntrySizeVal); (* e_phentsize Program header table entry size *) + Write2(phNumVal); (* e_phnum Program header table entry count *) + Write2(shEntrySizeVal); (* e_shentsize Section header table entry size *) + Write2(shNumVal); (* e_shnum Section header table entry count *) + Write2(shStrndxVal); (* e_shstrndx Section header string table index *) + ASSERT(Ro.Pos() = elfHeaderSizeVal, 101) + END WriteElfHeader; + + PROCEDURE FixupElfHeader; + BEGIN + Ro.SetPos(entryPos); + Write4(phOffsetVal); + Write4(shOffsetVal) + END FixupElfHeader; + + PROCEDURE WriteNullSectionHeader; + BEGIN + Write4(0); (* sh_name Section name (string tbl index) *) + Write4(0); (* SHT_NULL sh_type Section type *) + Write4(0); (* sh_flags Section flags *) + Write4(0); (* ELF header + program header table; sh_addr Section virtual addr at execution *) + Write4(0); (* sh_offset Section file offset *) + Write4(0); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(0); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteNullSectionHeader; + + PROCEDURE WriteTextSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".text", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(1); (* SHT_PROGBITS sh_type Section type *) + Write4(2H + 4H); (* SHF_ALLOC + SHF_EXECINSTR sh_flags Section flags *) + Write4(text.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(text.fileOffset); (* sh_offset Section file offset *) + Write4(text.size); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(textAlign); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteTextSectionHeader; + + PROCEDURE WriteRelTextSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".rel.text", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(9); (* SHT_REL sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(reltext.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(reltext.fileOffset); (* sh_offset Section file offset *) + Write4(reltext.size); (* sh_size Section size in bytes *) + Write4(dynsymIndexVal); (* sh_link Link to another section -> index of the associated symbol table *) + Write4(textIndexVal); (* sh_info Additional section information -> index of the relocated section *) + Write4(relAlign); (* sh_addralign Section alignment *) + Write4(relEntrySizeVal) (* sh_entsize Entry size if section holds table *) + END WriteRelTextSectionHeader; + + PROCEDURE WriteRelRodataSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".rel.rodata", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(9); (* SHT_REL sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(relrodata.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(relrodata.fileOffset); (* sh_offset Section file offset *) + Write4(relrodata.size); (* sh_size Section size in bytes *) + Write4(dynsymIndexVal); (* sh_link Link to another section -> index of the associated symbol table *) + Write4(rodataIndexVal); (* sh_info Additional section information -> index of the relocated section *) + Write4(relAlign); (* sh_addralign Section alignment *) + Write4(relEntrySizeVal) (* sh_entsize Entry size if section holds table *) + END WriteRelRodataSectionHeader; + + PROCEDURE WriteRodataSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".rodata", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(1); (* SHT_PROGBITS sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(rodata.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(rodata.fileOffset); (* sh_offset Section file offset *) + Write4(rodata.size); (* sh_size Section size in bytes *) + Write4(0); (* sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(rodataAlign); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteRodataSectionHeader; + + PROCEDURE WriteDynsymSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".dynsym", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(11); (* SHT_DYNSYM sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(dynsym.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(dynsym.fileOffset); (* sh_offset Section file offset *) + Write4(dynsym.size); (* sh_size Section size in bytes *) + Write4(dynstrIndexVal); (* sh_link Link to another section -> index of the associated string table *) + expPos := Ro.Pos(); + Write4(fixup); (* sh_info Additional section information -> see docu 4-17 *) + Write4(dynsymAlign); (* sh_addralign Section alignment *) + Write4(dynsymEntrySizeVal) (* sh_entsize Entry size if section holds table *) + END WriteDynsymSectionHeader; + + PROCEDURE FixupDynsymSectionHeader; + BEGIN + Ro.SetPos(expPos); + Write4(dynsymInfoVal) + END FixupDynsymSectionHeader; + + PROCEDURE WriteDynstrSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".dynstr", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(3); (* SHT_STRTAB sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(dynstr.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(dynstr.fileOffset); (* sh_offset Section file offset *) + Write4(dynstr.size); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(dynstrAlign); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteDynstrSectionHeader; + + PROCEDURE WriteHashSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".hash", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(5); (* SHT_HASH sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(hash.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(hash.fileOffset); (* sh_offset Section file offset *) + Write4(hash.size); (* sh_size Section size in bytes *) + Write4(dynsymIndexVal); (* sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(hashAlign); (* sh_addralign Section alignment *) + Write4(4H) (* sh_entsize Entry size if section holds table *) + END WriteHashSectionHeader; + + PROCEDURE WriteGotSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".got", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(1); (* SHT_PROGBITS sh_type Section type *) + Write4(2H + 1H); (* SHF_ALLOC + SHF_WRITE sh_flags Section flags *) + Write4(got.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(got.fileOffset); (* sh_offset Section file offset *) + Write4(got.size); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(gotAlign); (* sh_addralign Section alignment *) + Write4(gotEntrySizeVal) (* sh_entsize Entry size if section holds table *) + END WriteGotSectionHeader; + + PROCEDURE WriteBssSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".bss", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(8); (* SHT_NOBITS sh_type Section type *) + Write4(2H + 1H); (* SHF_ALLOC + SHF_WRITE sh_flags Section flags *) + Write4(bss.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(bss.fileOffset); (* sh_offset Section file offset *) + Write4(bss.size); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(bssAlign); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteBssSectionHeader; + + PROCEDURE WriteDynamicSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".dynamic", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(6); (* SHT_DYNAMIC sh_type Section type *) + Write4(2H); (* SHF_ALLOC sh_flags Section flags *) + Write4(dynamic.memOffset); (* sh_addr Section virtual addr at execution *) + Write4(dynamic.fileOffset); (* sh_offset Section file offset *) + Write4(dynamic.size); (* sh_size Section size in bytes *) + Write4(dynstrIndexVal); (* sh_link Link to another section -> index of the associated symbol table *) + Write4(0); (* sh_info Additional section information *) + Write4(dynamicAlign); (* sh_addralign Section alignment *) + Write4(dynamicEntrySizeVal) (* sh_entsize Entry size if section holds table *) + END WriteDynamicSectionHeader; + + PROCEDURE WriteShstrtabSectionHeader; + VAR i: INTEGER; + BEGIN + headerstrtab.AddName(".shstrtab", i); + Write4(i); (* sh_name Section name (string tbl index) *) + Write4(3); (* SHT_STRTAB sh_type Section type *) + Write4(0); (* sh_flags Section flags *) + Write4(0); (* sh_addr Section virtual addr at execution *) + Write4(shstrtab.fileOffset); (* sh_offset Section file offset *) + shstrtabPos := Ro.Pos(); + Write4(fixup); (* sh_size Section size in bytes *) + Write4(0); (* SHN_UNDEF sh_link Link to another section *) + Write4(0); (* sh_info Additional section information *) + Write4(shstrtabAlign); (* sh_addralign Section alignment *) + Write4(0) (* sh_entsize Entry size if section holds table *) + END WriteShstrtabSectionHeader; + + PROCEDURE FixupShstrtabSectionHeader; + BEGIN + Ro.SetPos(shstrtabPos); + Write4(shstrtab.size) + END FixupShstrtabSectionHeader; + + PROCEDURE WriteRelSectionHeaders; + BEGIN + WriteRelTextSectionHeader; + WriteRelRodataSectionHeader + END WriteRelSectionHeaders; + + PROCEDURE WriteSectionHeaderTable; + BEGIN + shOffsetVal := Ro.Pos(); + WriteNullSectionHeader; + WriteTextSectionHeader; + WriteRodataSectionHeader; + WriteRelSectionHeaders; + WriteDynsymSectionHeader; + WriteDynstrSectionHeader; + WriteHashSectionHeader; + WriteGotSectionHeader; + WriteDynamicSectionHeader; + WriteBssSectionHeader; + WriteShstrtabSectionHeader (* see shStrndxVal *) + (* see shNumVal *) + END WriteSectionHeaderTable; + + PROCEDURE FixupSectionHeaderTable; + BEGIN + FixupDynsymSectionHeader; + FixupShstrtabSectionHeader + END FixupSectionHeaderTable; + + PROCEDURE WriteTextSegment; + BEGIN + Write4(1); (* PT_LOAD *) + Write4(0); (* offset *) + Write4(0); (* vaddr *) + Write4(0); (* paddr *) + Write4(textSegmentSizeVal); (* file size *) + Write4(textSegmentSizeVal); (* mem size *) + Write4(4H + 1H + 2H); (* flags: R+E+W *) + Write4(pageSize) (* I386 page size *) + END WriteTextSegment; + + PROCEDURE WriteDataSegment; + BEGIN + Write4(1); (* PT_LOAD *) + Write4(got.fileOffset); (* offset text segment size *) + Write4(got.memOffset); (* vaddr: offset + alignment * nof pages of text segment *) + Write4(got.memOffset); (* paddr: offset + alignment * nof pages of text segment *) + Write4(dataSegmentSizeVal); (* file size *) + Write4(dataSegmentSizeVal + bss.size); (* mem size -> dataSegmentSizeVal + NOBITS sections *) + Write4(4H + 2H); (* flags: R+W *) + Write4(pageSize) (* I386 page size *) + END WriteDataSegment; + + PROCEDURE WriteDynamicSegment; + BEGIN + Write4(2); (* PT_DYNAMIC *) + Write4(dynamic.fileOffset); (* offset text segment size *) + Write4(dynamic.memOffset); (* vaddr: offset of .dynamic section *) + Write4(dynamic.memOffset); (* paddr: vaddr + alignment * nof pages of text segment *) + Write4(dynamicSegmentSizeVal); (* file size *) + Write4(dynamicSegmentSizeVal); (* mem size *) + Write4(4H + 2H); (* flags: R+W *) + Write4(dynamicAlign) (* dynamic section alignement*) + END WriteDynamicSegment; + + PROCEDURE WriteProgramHeaderTable; + BEGIN + phOffsetVal := Ro.Pos(); + WriteTextSegment; (* .text .rel.text .rodata .dynsym .dynstr .hash *) + WriteDataSegment; (* .got .dynamic .bss *) + WriteDynamicSegment (* .dynamic *) + END WriteProgramHeaderTable; + + PROCEDURE SearchObj (mod: Module; VAR name: ARRAY OF SHORTCHAR; m, fp, opt: INTEGER; VAR adr: INTEGER); + VAR dir, len, ntab, f, id, l, r, p, n, i, j: INTEGER; nch, och: SHORTCHAR; + BEGIN + Get(mod, mod.ms + modExports, dir); DEC(dir, rodata.memOffset + mod.ma); Get(mod, dir, len); INC(dir, 4); + Get(mod, mod.ms + modNames, ntab); DEC(ntab, rodata.memOffset + mod.ma); + IF name # "" THEN + l := 0; r := len; + WHILE l < r DO (* binary search *) + n := (l + r) DIV 2; p := dir + n * 16; + Get(mod, p + 8, id); + i := 0; j := ntab + id DIV 256; nch := name[0]; och := SHORT(CHR(mod.data[j])); + WHILE (nch = och) & (nch # 0X) DO INC(i); INC(j); nch := name[i]; och := SHORT(CHR(mod.data[j])) END; + IF och = nch THEN + IF id MOD 16 = m THEN + Get(mod, p, f); + IF m = mTyp THEN + IF ODD(opt) THEN Get(mod, p + 4, f) END; + IF (opt > 1) & (id DIV 16 MOD 16 # mExported) THEN + WriteString(mod.name$); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name$); + WriteString(" has wrong visibility"); WriteLn; error := TRUE + END; + Get(mod, p + 12, adr) + ELSIF m = mVar THEN + Get(mod, p + 4, adr); INC(adr, bss.memOffset + mod.va) + ELSIF m = mProc THEN + Get(mod, p + 4, adr); INC(adr, text.memOffset + mod.ca) + END; + IF f # fp THEN + WriteString(mod.name$); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name$); + WriteString(" has wrong fprint"); WriteLn; error := TRUE + END + ELSE + WriteString(mod.name$); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name$); + WriteString(" has wrong class"); WriteLn; error := TRUE + END; + RETURN + END; + IF och < nch THEN l := n + 1 ELSE r := n END + END; + WriteString(mod.name$); WriteChar("."); WriteSString(name); + WriteString(" not found (imported from "); WriteString(impg.name$); + WriteChar(")"); WriteLn; error := TRUE + ELSE (* anonymous type *) + WHILE len > 0 DO + Get(mod, dir + 4, f); Get(mod, dir + 8, id); + IF (f = fp) & (id MOD 16 = mTyp) & (id DIV 256 = 0) THEN + Get(mod, dir + 12, adr); RETURN + END; + DEC(len); INC(dir, 16) + END; + WriteString("anonymous type in "); WriteString(mod.name$); + WriteString(" not found"); WriteLn; error := TRUE + END + END SearchObj; + + PROCEDURE CollectExports (mod: Module); + VAR dir, len, ntab, id, i, j, n: INTEGER; e, exp: Export; + BEGIN + ASSERT(mod.intf & ~mod.dll, 20); + Get(mod, mod.ms + modExports, dir); + DEC(dir, rodata.memOffset + mod.ma); Get(mod, dir, len); INC(dir, 4); + Get(mod, mod.ms + modNames, ntab); DEC(ntab, rodata.memOffset + mod.ma); n := 0; + WHILE n < len DO + Get(mod, dir + 8, id); + IF (id DIV 16 MOD 16 # mInternal) & (id MOD 16 = mProc) THEN (* exported procedure *) + NEW(exp); + i := 0; j := ntab + id DIV 256; + WHILE mod.data[j] # 0 DO exp.name[i] := SHORT(CHR(mod.data[j])); INC(i); INC(j) END; + exp.name[i] := 0X; + Get(mod, dir + 4, exp.adr); + IF id MOD 16 = mProc THEN + INC(exp.adr, text.memOffset + mod.ca) + ELSE + HALT(126); + ASSERT(id MOD 16 = mVar); INC(exp.adr, bss.memOffset + mod.va) + END; + IF (firstExp = NIL) OR (exp.name < firstExp.name) THEN + exp.next := firstExp; firstExp := exp; + IF lastExp = NIL THEN lastExp := exp END + ELSE + e := firstExp; + WHILE (e.next # NIL) & (exp.name > e.next.name) DO e := e.next END; + exp.next := e.next; e.next := exp; + IF lastExp = e THEN lastExp := exp END + END; + INC(numExp) + END; + INC(n); INC(dir, 16) + END + END CollectExports; + + PROCEDURE Relocate0 (link, adr, sym: INTEGER); + CONST + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; (* BB fixup types *) + noElfType = MIN(INTEGER); + VAR + offset, linkadr, bbType, elfType, n, x: INTEGER; relText: BOOLEAN; + BEGIN + WHILE link # 0 DO + RNum(offset); + WHILE link # 0 DO + IF link > 0 THEN + n := (code[link] MOD 256) + (code[link+1] MOD 256) * 256 + code[link+2] * 65536; + bbType := code[link+3]; + linkadr := text.memOffset + impg.ca + link + ELSE + n := (impg.data[-link] MOD 256) + (impg.data[-link+1] MOD 256) * 256 + impg.data[-link+2] * 65536; + bbType := impg.data[-link+3]; + linkadr := rodata.memOffset + impg.ma - link + END; + elfType := noElfType; + IF bbType = absolute THEN + IF sym = noSymbol THEN + x := adr + offset; + elfType := r386Relative + ELSE + x := 0H; + elfType := r38632 + sym * 256 + END + ELSIF bbType = relative THEN + IF sym = noSymbol THEN + x := adr + offset - linkadr - 4 + ELSE + x := 0FFFFFFFCH; + elfType := r386pc32 + sym * 256 + END + ELSIF bbType = copy THEN + Get(impd, adr + offset - rodata.memOffset - impd.ma, x); + IF x # 0 THEN elfType := r386Relative END + ELSIF bbType = table THEN + x := adr + n; n := link + 4; + elfType := r386Relative + ELSIF bbType = tableend THEN + x := adr + n; n := 0; + elfType := r386Relative + ELSE HALT(99) + END; + relText := link > 0; + IF link > 0 THEN + code[link] := SHORT(SHORT(x)); + code[link+1] := SHORT(SHORT(x DIV 100H)); + code[link+2] := SHORT(SHORT(x DIV 10000H)); + code[link+3] := SHORT(SHORT(x DIV 1000000H)) + ELSE + link := -link; + impg.data[link] := SHORT(SHORT(x)); + impg.data[link+1] := SHORT(SHORT(x DIV 100H)); + impg.data[link+2] := SHORT(SHORT(x DIV 10000H)); + impg.data[link+3] := SHORT(SHORT(x DIV 1000000H)) + END; + IF elfType # noElfType THEN + IF relText THEN + relTextTab.Add(linkadr, elfType) + ELSE + relRodataTab.Add(linkadr, elfType) + END + END; + link := n + END; + RNum(link) + END + END Relocate0; + + PROCEDURE Relocate (adr: INTEGER); + VAR link: INTEGER; + BEGIN + RNum(link); Relocate0(link, adr, noSymbol) + END Relocate; + + PROCEDURE RelocateSymbol (adr, sym: INTEGER); + VAR link: INTEGER; + BEGIN + RNum(link); Relocate0(link, adr, sym) + END RelocateSymbol; + + PROCEDURE SymbolIndex (IN name: Name): INTEGER; + VAR n: INTEGER; exp: Export; m: Module; + BEGIN + n := 0; exp := NIL; + m := modList; + WHILE (m # NIL) & (exp = NIL) DO + IF m.dll THEN + exp := m.exp; + WHILE (exp # NIL) & (exp.name$ # name$) DO + INC(n); + exp := exp.next + END + END; + m := m.next + END; + ASSERT((exp # NIL) & (exp.name$ = name$), 60); + RETURN firstDllSymbolVal + n + END SymbolIndex; + + PROCEDURE WriteTextSection; + VAR mod, m: Module; i, x, a, sym, fp, opt: INTEGER; exp: Export; name: Name; + BEGIN + ASSERT(isDll, 126); + ASSERT(~doWrite OR (Ro.Pos() = text.fileOffset), 100); + WriteCh(053X); (* push ebx *) (* _init() *) + a := 1; + WriteCh(0BBX); Write4(rodata.memOffset + last.ma + last.ms); (* mov bx, modlist *) + relTextTab.Add(text.memOffset + a + 1, r386Relative); + INC(a, 5); + IF isStatic THEN + m := modList; + WHILE m # NIL DO + IF ~m.dll THEN + WriteCh(0E8X); INC(a, 5); Write4(m.ca - a) (* call body *) + END; + m := m.next + END + ELSE + WriteCh(0E8X); INC(a, 5); Write4(main.ca - a) (* call main *) + END; + WriteCh(05BX); (* pop ebx *) + WriteCh(0C3X); (* ret *) + INC(a, 2); + finiMemOffsetVal := text.memOffset + a; + WriteCh(053X); (* push ebx *) (* _fini() *) + INC(a); + finiPos := text.memOffset + a; + IF isStatic THEN + i := 0; + WHILE i < numMod DO (* nop for call terminator *) + WriteCh(02DX); Write4(0); (* sub EAX, 0 *) + INC(i); INC(a, 5) + END + ELSE + WriteCh(02DX); Write4(0); (* sub EAX, 0 *) + INC(a, 5) + END; + lastTerm := a; + WriteCh(05BX); (* pop ebx *) + WriteCh(0C3X); (* ret *) + IF ~doWrite THEN NEW(code, maxCode) END; + mod := modList; + WHILE mod # NIL DO + impg := mod; + impd := mod; + IF ~mod.dll THEN + mod.file := ThisFile(mod.fileName); + R := mod.file.NewReader(R); + R.SetPos(mod.hs); + IF ~doWrite THEN NEW(mod.data, mod.ms + mod.ds) END; + R.ReadBytes(mod.data^, 0, mod.ms + mod.ds); + R.ReadBytes(code^, 0, mod.cs); + RNum(x); + IF x # 0 THEN + IF (mod # kernel) & (kernel # NIL) THEN + SearchObj(kernel, newRec, mProc, NewRecFP, 0, a); + IF error THEN RETURN END; + Relocate0(x, a, noSymbol) + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; + error := TRUE; + RETURN + END + END; + RNum(x); + IF x # 0 THEN + IF (mod # kernel) & (kernel # NIL) THEN + SearchObj(kernel, newArr, mProc, NewArrFP, 0, a); + IF error THEN RETURN END; + Relocate0(x, a, noSymbol) + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; error := TRUE; + RETURN + END + END; + Relocate(rodata.memOffset + mod.ma); (* metalink *) + Relocate(rodata.memOffset + mod.ma + mod.ms); (* desclink *) + Relocate(text.memOffset + mod.ca); (* codelink *) + Relocate(bss.memOffset + mod.va); (* datalink *) + i := 0; + WHILE i < mod.ni DO + m := mod.imp[i]; impd := m; RNum(x); + WHILE x # 0 DO + ReadName(name); RNum(fp); opt := 0; + IF x = mTyp THEN RNum(opt) END; + sym := noSymbol; + IF m.dll THEN + IF (x = mProc) OR (x = mVar) THEN + exp := m.exp; + WHILE exp.name # name DO exp := exp.next END; + a := noAddr; + sym := SymbolIndex(name) + END + ELSE + SearchObj(m, name, x, fp, opt, a); + IF error THEN RETURN END + END; + IF x # mConst THEN + RelocateSymbol(a, sym) + END; + RNum(x) + END; + IF ~m.dll THEN + Get(mod, mod.ms + modImports, x); DEC(x, rodata.memOffset + mod.ma); INC(x, 4 * i); + Put(mod, x, rodata.memOffset + m.ma + m.ms); (* imp ref *) + relRodataTab.Add(rodata.memOffset + mod.ma + x, r386Relative); + Get(m, m.ms + modRefcnt, x); Put(m, m.ms + modRefcnt, x + 1) (* inc ref count *) + END; + INC(i) + END; + WriteBytes(code^, 0, mod.cs); + IF mod.intf THEN CollectExports(mod) END; + mod.file.Close; mod.file := NIL + END; + mod := mod.next + END; + ASSERT(~doWrite OR (text.size = Ro.Pos() - text.fileOffset), 101) + END WriteTextSection; + + PROCEDURE WriteTermCode (m: Module; i: INTEGER); + VAR x: INTEGER; + BEGIN + IF m # NIL THEN + IF m.dll THEN WriteTermCode(m.next, i) + ELSE + IF isStatic THEN WriteTermCode(m.next, i + 1) END; + Get(m, m.ms + modTerm, x); (* terminator address in mod desc*) + IF x = 0 THEN + WriteCh(005X); Write4(0) (* add EAX, 0 (nop) *) + ELSE + WriteCh(0E8X); Write4(x - lastTerm + 5 * i - text.memOffset) (* call term *) + END + END + END + END WriteTermCode; + + PROCEDURE FixupTextSection; + BEGIN + ASSERT(isDll, 126); + Ro.SetPos(finiPos); + IF isStatic THEN + WriteTermCode(modList, 0) + ELSE + WriteTermCode(main, 0) + END + END FixupTextSection; + + PROCEDURE WriteRelSection (IN s: Section; IN t: RelTab); + VAR i: INTEGER; + BEGIN + ASSERT(s.fileOffset = Ro.Pos(), 100); + i := 0; + WHILE i # t.cur DO + Write4(t.tab[i].offset); + Write4(t.tab[i].type); + INC(i) + END; + ASSERT(s.size = Ro.Pos() - s.fileOffset, 101) + END WriteRelSection; + + PROCEDURE WriteRelSections; + BEGIN + WriteRelSection(reltext, relTextTab); + WriteRelSection(relrodata, relRodataTab) + END WriteRelSections; + + PROCEDURE WriteRodataSection; + VAR mod, lastMod: Module; x: INTEGER; + BEGIN + ASSERT(~doWrite OR (rodata.fileOffset = Ro.Pos()), 100); + mod := modList; lastMod := NIL; + WHILE mod # NIL DO + IF ~mod.dll THEN + IF lastMod # NIL THEN + Put(mod, mod.ms, rodata.memOffset + lastMod.ma + lastMod.ms); (* mod list *) + relRodataTab.Add(rodata.memOffset + mod.ma + mod.ms, r386Relative) + END; + Get(mod, mod.ms + modOpts, x); + IF isStatic THEN INC(x, 10000H) END; (* set init bit (16) *) + IF isDll THEN INC(x, 1000000H) END; (* set dll bit (24) *) + Put(mod, mod.ms + modOpts, x); + WriteBytes(mod.data^, 0, mod.ms + mod.ds); + lastMod := mod + END; + mod := mod.next + END; + ASSERT(~doWrite OR (rodata.size = Ro.Pos() - rodata.fileOffset), 101) + END WriteRodataSection; + + PROCEDURE WriteSymbolTableEntry (IN name: ARRAY OF SHORTCHAR; val, size: INTEGER; bind, type: BYTE; shndx: INTEGER); + VAR i: INTEGER; info: SHORTCHAR; + BEGIN + IF name # "" THEN dynstrtab.AddName(name, i) + ELSE i := 0 + END; + Write4(i); + Write4(val); + Write4(size); + info := SHORT(CHR(bind * 16 + type)); + WriteCh(info); + WriteCh(0X); (* Symbol visibility *) + Write2(shndx) + END WriteSymbolTableEntry; + + PROCEDURE FixupSymbolTableEntry (val, size: INTEGER; bind, type: BYTE; shndx: INTEGER); + VAR info: SHORTCHAR; + BEGIN + Ro.SetPos(Ro.Pos() + 4); (* skip name *) + Write4(val); + Write4(size); + info := SHORT(CHR(bind * 16 + type)); + WriteCh(info); + WriteCh(0X); (* Symbol visibility *) + Write2(shndx) + END FixupSymbolTableEntry; + + PROCEDURE WriteDynsymSection; + VAR e: Export; m: Module; i: INTEGER; + BEGIN + ASSERT(Ro.Pos() = dynsym.fileOffset, 100); + WriteSymbolTableEntry("", 0, 0, 0, 0, 0); + WriteSymbolTableEntry("", text.memOffset, 0, stbLocal, sttSection, 1); (* .text section *) + WriteSymbolTableEntry("", rodata.memOffset, 0, stbLocal, sttSection, 2); (* .rodata section *) + WriteSymbolTableEntry("", reltext.memOffset, 0, stbLocal, sttSection, 3); (* .rel.text.section *) + WriteSymbolTableEntry("", relrodata.memOffset, 0, stbLocal, sttSection, 4); (* .rel.rodata section *) + WriteSymbolTableEntry("", dynsym.memOffset, 0, stbLocal, sttSection, 5); (* .dynsym section *) + WriteSymbolTableEntry("", dynstr.memOffset, 0, stbLocal, sttSection, 6); (* .dynstr section *) + WriteSymbolTableEntry("", hash.memOffset, 0, stbLocal, sttSection, 7); (* .hash section *) + WriteSymbolTableEntry("", got.memOffset, 0, stbLocal, sttSection, 8); (* .got section *) + WriteSymbolTableEntry("", dynamic.memOffset, 0, stbLocal, sttSection, 9); (* .dynamic section *) + WriteSymbolTableEntry("", bss.memOffset, 0, stbLocal, sttSection, 10); (* .bss section *) + dynsymInfoVal := 11; + i := dynsymInfoVal; + WriteSymbolTableEntry("_DYNAMIC", dynamic.memOffset, 0, stbGlobal, sttObject, shnAbs); + hashtab[i] := "_DYNAMIC"; + INC(i); + ASSERT(i = firstDllSymbolVal); + m := modList; + WHILE m # NIL DO + IF m.dll THEN + e := m.exp; + WHILE e # NIL DO + WriteSymbolTableEntry(e.name, 0, 0, stbGlobal, sttNotype, shnUnd); + hashtab[i] := e.name$; + INC(i); + e := e.next + END + END; + m := m.next + END; + e := firstExp; + WHILE e # NIL DO + WriteSymbolTableEntry(e.name, fixup, 0, stbGlobal, sttFunc, textIndexVal); + hashtab[i] := e.name$; INC(i); + e := e.next + END; + WriteSymbolTableEntry("_GLOBAL_OFFSET_TABLE_", got.memOffset, 0, stbGlobal, sttObject, shnAbs); + hashtab[i] := "_GLOBAL_OFFSET_TABLE_"; + ASSERT(dynsym.size = Ro.Pos() - dynsym.fileOffset, 101) + END WriteDynsymSection; + + PROCEDURE FixupDynsymSection; + VAR e: Export; m: Module; + BEGIN + Ro.SetPos(dynsym.fileOffset + dynsymEntrySizeVal * firstDllSymbolVal); + m := modList; + WHILE m # NIL DO + IF m.dll THEN + e := m.exp; + WHILE e # NIL DO + Ro.SetPos(Ro.Pos() + dynsymEntrySizeVal); + e := e.next + END + END; + m := m.next + END; + Ro.SetPos(Ro.Pos() + 4); + e := firstExp; + WHILE e # NIL DO + Write4(e.adr); + Ro.SetPos(Ro.Pos() + 12); + e := e.next + END + END FixupDynsymSection; + + PROCEDURE WriteStringTable (IN t: Strtab); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE i # t.cur DO + WriteCh(t.tab[i]); + INC(i) + END + END WriteStringTable; + + PROCEDURE WriteDynstrSection; + BEGIN + ASSERT(Ro.Pos() = dynstr.fileOffset, 100); + WriteStringTable(dynstrtab); + ASSERT(dynstr.size = Ro.Pos() - dynstr.fileOffset, 101) + END WriteDynstrSection; + + PROCEDURE Hash (name: ARRAY OF SHORTCHAR): INTEGER; + VAR i, h, g: INTEGER; + BEGIN + h := 0; i := 0; + WHILE name[i] # 0X DO + h := ASH(h, 4) + ORD(name[i]); + g := ORD(BITS(h) * BITS(0F0000000H)); + IF g # 0 THEN + h := ORD(BITS(h) / BITS(SHORT((g MOD 100000000L) DIV 1000000H))) + END; + h := ORD(BITS(h) * (-BITS(g))); + INC(i) + END; + RETURN h + END Hash; + + PROCEDURE AddToChain (VAR c: ARRAY OF INTEGER; i, idx: INTEGER); + VAR k: INTEGER; + BEGIN + IF c[i] # 0 THEN + k := i; + WHILE c[k] # 0 DO k := c[k] END; + c[k] := idx + ELSE + c[i] := idx + END + END AddToChain; + + PROCEDURE WriteHashSection; + VAR n, i, hi: INTEGER; b, c: POINTER TO ARRAY OF INTEGER; + BEGIN + ASSERT(hash.fileOffset = Ro.Pos(), 100); + n := dynsym.size DIV dynsymEntrySizeVal; (* number of enties in the symbol table *) + NEW(b, n); + NEW(c, n); + i := 0; + WHILE i # n DO + c[i] := 0; (* STN_UNDEF *) + IF hashtab[i] # "" THEN + hi := Hash(hashtab[i]) MOD n; + IF b[hi] # 0 THEN (* another word has the same index *) + AddToChain(c, i, b[hi]) (*c[i] := b[hi]*) + END; + b[hi] := i + END; + INC(i) + END; + Write4(n); (* nbucket *) + Write4(n); (* nchain *) + i := 0; + WHILE i # n DO + Write4(b[i]); + INC(i) + END; + i := 0; + WHILE i # n DO + Write4(c[i]); + INC(i) + END; + ASSERT(hash.size = Ro.Pos() - hash.fileOffset, 101) + END WriteHashSection; + + PROCEDURE WriteGotSection; + BEGIN + ASSERT(got.fileOffset = Ro.Pos(), 100); + Write4(dynamic.memOffset); (* addr of .dynamic section *) + Write4(0); (* reserved for ? *) + Write4(0); (* reserved for ? *) + ASSERT(got.size = Ro.Pos() - got.fileOffset, 101) + END WriteGotSection; + + PROCEDURE WriteDynamicSectionEntry (tag, val: INTEGER); + BEGIN + Write4(tag); + Write4(val) + END WriteDynamicSectionEntry; + + PROCEDURE WriteDynamicSection; + CONST dtNull = 0; dtNeeded = 1; dtHash = 4; dtStrtab = 5; dtSymtab = 6; + dtStrsz = 10; dtSyment = 11; dtInit = 12; dtFini = 13; dtSoname = 14; dtRel = 17; dtRelsz = 18; dtRelent = 19; + dtTextrel = 22; + VAR i: INTEGER; + BEGIN + ASSERT(dynamic.fileOffset = Ro.Pos(), 100); + WriteDynamicSectionEntry(dtSoname, fixup); + WriteDynamicSectionEntry(dtFini, fixup); + WriteDynamicSectionEntry(dtInit, text.memOffset); + WriteDynamicSectionEntry(dtHash, hash.memOffset); + WriteDynamicSectionEntry(dtStrtab, dynstr.memOffset); + WriteDynamicSectionEntry(dtSymtab, dynsym.memOffset); + WriteDynamicSectionEntry(dtStrsz, dynstr.size); + WriteDynamicSectionEntry(dtSyment, dynsymEntrySizeVal); + WriteDynamicSectionEntry(dtRel, reltext.memOffset); + WriteDynamicSectionEntry(dtRelsz, reltext.size + relrodata.size); + WriteDynamicSectionEntry(dtRelent, relEntrySizeVal); + i := 0; + WHILE neededIdx[i] # 0 DO + WriteDynamicSectionEntry(dtNeeded, neededIdx[i]); + INC(i) + END; + WriteDynamicSectionEntry(dtTextrel, 0); + WriteDynamicSectionEntry(dtNull, 0); (* DT_NULL: marks the end *) + ASSERT(dynamic.size = Ro.Pos() - dynamic.fileOffset, 101) + END WriteDynamicSection; + + PROCEDURE FixupDynamicSection; + VAR i: INTEGER; + BEGIN + Ro.SetPos(dynamic.fileOffset + 4); + Write4(sonameStrIndexVal); + Ro.SetPos(Ro.Pos() + 4); + Write4(finiMemOffsetVal) + END FixupDynamicSection; + + PROCEDURE WriteBssSection; + BEGIN +(* + The .bss section does not take space in the file. + This procedure serves consistency-check purposes. +*) + ASSERT(bss.fileOffset = Ro.Pos(), 100) + END WriteBssSection; + + PROCEDURE WriteShstrtabSection; + BEGIN + ASSERT(shstrtab.fileOffset = Ro.Pos(), 100); + WriteStringTable(headerstrtab); + shstrtab.size := Ro.Pos() - shstrtab.fileOffset + END WriteShstrtabSection; + + PROCEDURE GetImpListSize (OUT len: INTEGER; OUT count: INTEGER); + VAR m: Module; e: Export; + BEGIN + len := 0; count := 0; + m := modList; + WHILE m # NIL DO + IF m.dll THEN + e := m.exp; + WHILE e # NIL DO + INC(len, LEN(e.name$) + 1); + INC(count); + e := e.next + END + END; + m := m.next + END + END GetImpListSize; + + PROCEDURE GetExpListSize (OUT len: INTEGER; OUT count: INTEGER); + VAR e: Export; + BEGIN + count := 0; len := 0; + e := firstExp; + WHILE e # NIL DO + INC(len, LEN(e.name$) + 1); + INC(count); + e := e.next + END + END GetExpListSize; + + PROCEDURE DynsymSize (init: INTEGER): INTEGER; + VAR size: INTEGER; + BEGIN + size := init; + INC(size, dynsymEntrySizeVal * 11); (* sections entries *) + INC(size, dynsymEntrySizeVal); (* _DYNAMIC symbol *) + INC(size, dynsymEntrySizeVal); (* _GLOBAL_OFFSET_TABLE_ symbol *) + RETURN size + END DynsymSize; + + PROCEDURE DynstrSize (init: INTEGER): INTEGER; + VAR size: INTEGER; + BEGIN + size := init + 1; + INC(size, dynstrtab.cur - 1); + INC(size, LEN(soName$) + 1); (* library name *) + INC(size, 9); (* "_DYNAMIC" symbol + 0X *) + INC(size, 21 + 1); (* "_GLOBAL_OFFSET_TABLE_" symbol + trailing 0X *) + RETURN size + END DynstrSize; + + PROCEDURE DynamicSize (init: INTEGER): INTEGER; + VAR i, size: INTEGER; + BEGIN + size := init; + i := 0; + WHILE neededIdx[i] # 0 DO + INC(size, dynamicEntrySizeVal); + INC(i) + END; + RETURN size + END DynamicSize; + + PROCEDURE CalculateLayout; + VAR headerSize, impCount, expCount, impLen, expLen: INTEGER; + BEGIN + ASSERT(~error, 20); + headerSize := elfHeaderSizeVal + shEntrySizeVal * shNumVal + phEntrySizeVal * phNumVal; + text.fileOffset := Aligned(headerSize, textAlign); + text.memOffset := text.fileOffset; + text.size := CodeSize; + rodata.fileOffset := Aligned(text.fileOffset + text.size, rodataAlign); + rodata.memOffset := rodata.fileOffset; + rodata.size := ConSize; + reltext.fileOffset := Aligned(rodata.fileOffset + rodata.size, relAlign); + reltext.memOffset := reltext.fileOffset; + doWrite := FALSE; + WriteTextSection; (* this only calculates the number of text relocations *) + IF error THEN RETURN END; + reltext.size := relEntrySizeVal * relTextTab.cur; + relrodata.fileOffset := reltext.fileOffset + reltext.size; + relrodata.memOffset := relrodata.fileOffset; + IF ~error THEN + WriteRodataSection (* this only calculates the number of data relocations *) + ELSE + RETURN + END; + relrodata.size := relEntrySizeVal * relRodataTab.cur; + dynsym.fileOffset := Aligned(relrodata.fileOffset + relrodata.size, dynsymAlign); + dynsym.memOffset := dynsym.fileOffset; + GetImpListSize(impLen, impCount); + GetExpListSize(expLen, expCount); + dynsym.size := DynsymSize((impCount + expCount) * dynsymEntrySizeVal); + dynstr.fileOffset := Aligned(dynsym.fileOffset + dynsym.size, dynstrAlign); + dynstr.memOffset := dynstr.fileOffset; + dynstr.size := DynstrSize(impLen + expLen); + hash.fileOffset := Aligned(dynstr.fileOffset + dynstr.size, hashAlign); + hash.memOffset := hash.fileOffset; + hash.size := 8 + dynsym.size DIV dynsymEntrySizeVal * 4 * 2; + got.fileOffset := Aligned(hash.fileOffset + hash.size, gotAlign); + got.memOffset := Aligned(got.fileOffset, pageSize) + got.fileOffset MOD pageSize; + got.size := 3 * gotEntrySizeVal; + dynamic.fileOffset := Aligned(got.fileOffset + got.size, dynamicAlign); + dynamic.memOffset := got.memOffset + dynamic.fileOffset - got.fileOffset; + dynamic.size := DynamicSize(13 * dynamicEntrySizeVal); + bss.fileOffset := Aligned(dynamic.fileOffset + dynamic.size, bssAlign); + bss.memOffset := dynamic.memOffset + bss.fileOffset - dynamic.fileOffset; + bss.size := DataSize; + shstrtab.fileOffset := Aligned(bss.fileOffset, shstrtabAlign); + shstrtab.size := fixup; + textSegmentSizeVal := got.fileOffset; + dataSegmentSizeVal := shstrtab.fileOffset - got.fileOffset; + dynamicSegmentSizeVal := shstrtab.fileOffset - dynamic.fileOffset; + relTextTab.cur := 0; + relRodataTab.cur := 0; + firstExp := NIL; lastExp := NIL; + doWrite := TRUE + END CalculateLayout; + + PROCEDURE WriteOut; + VAR res: INTEGER; + BEGIN + ASSERT(~error, 20); + Out := Files.dir.New(Files.dir.This(""), Files.ask); + IF Out # NIL THEN + Ro := Out.NewWriter(Ro); Ro.SetPos(0); + CalculateLayout; + IF ~error THEN WriteElfHeader END; + IF ~error THEN WriteSectionHeaderTable END; + IF ~error THEN WriteProgramHeaderTable END; + IF ~error THEN Align(textAlign); WriteTextSection END; + IF ~error THEN Align(rodataAlign); WriteRodataSection END; + IF ~error THEN Align(relAlign); WriteRelSections END; + IF ~error THEN Align(dynsymAlign); WriteDynsymSection END; + IF ~error THEN Align(dynstrAlign); WriteDynstrSection END; + IF ~error THEN Align(hashAlign); WriteHashSection END; + IF ~error THEN Align(gotAlign); WriteGotSection END; + IF ~error THEN Align(dynamicAlign); WriteDynamicSection END; + IF ~error THEN Align(bssAlign); WriteBssSection END; + IF ~error THEN Align(shstrtabAlign); WriteShstrtabSection END; + + IF ~error THEN FixupElfHeader END; + IF ~error THEN FixupSectionHeaderTable END; + IF ~error THEN FixupTextSection END; + IF ~error THEN FixupDynsymSection END; + IF ~error THEN FixupDynamicSection END; + Out.Register(soName$, "so", Files.ask, res); + IF res # 0 THEN error := TRUE END + ELSE + error := TRUE + END + END WriteOut; + + PROCEDURE ResetHashtab; + VAR i: INTEGER; + BEGIN + i := 0; + WHILE i # LEN(hashtab) DO + hashtab[i] := ""; + INC(i) + END + END ResetHashtab; + + PROCEDURE ResetNeededIdx; + VAR i: INTEGER; + BEGIN + i := 0; + WHILE i # LEN(neededIdx) DO + neededIdx[i] := 0; + INC(i) + END + END ResetNeededIdx; + + PROCEDURE MakeSoName (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: Files.Name; ch: CHAR; + BEGIN + ASSERT((type = "") OR (type[0] = "."), 20); + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSIF i < LEN(name) - (LEN(type$) + 1) THEN + IF type = "" THEN ext := ".so" ELSE ext := type$ END; + j := 0; ch := ext[0]; + WHILE ch # 0X DO + IF (ch >= "A") & (ch <= "Z") THEN + ch := CHR(ORD(ch) + ORD("a") - ORD("A")) + END; + name[i] := ch; INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END MakeSoName; + + (* A. V. Shiryaev: Scanner *) + + PROCEDURE (VAR S: Scanner) SetPos (x: INTEGER), NEW; + BEGIN + S.rider.i := x + END SetPos; + + PROCEDURE (VAR S: Scanner) ConnectTo (IN src: ARRAY OF CHAR), NEW; + BEGIN + NEW(S.rider.s, LEN(src$) + 1); + S.rider.s^ := src$; + S.rider.i := 0; + S.start := 0; + S.type := TMEOT + END ConnectTo; + + PROCEDURE (VAR R: ScanRider) ReadPrevChar (VAR ch: CHAR), NEW; + BEGIN + ch := R.s[R.i] + END ReadPrevChar; + + PROCEDURE (VAR R: ScanRider) ReadChar (VAR ch: CHAR), NEW; + BEGIN + ch := R.s[R.i]; + INC(R.i) + END ReadChar; + + PROCEDURE (VAR R: ScanRider) Pos (): INTEGER, NEW; + BEGIN + RETURN R.i + END Pos; + + PROCEDURE (VAR S: Scanner) Scan, NEW; + VAR j: INTEGER; + + PROCEDURE IsLetter (c: CHAR): BOOLEAN; + BEGIN + RETURN ((c >= 'A') & (c <= 'Z')) OR ((c >= 'a') & (c <= 'z')) OR (c = '_') + END IsLetter; + + PROCEDURE IsDigit (c: CHAR): BOOLEAN; + BEGIN + RETURN (c >= '0') & (c <= '9') + END IsDigit; + + BEGIN + WHILE (S.rider.i < LEN(S.rider.s$)) & (S.rider.s[S.rider.i] = ' ') DO + INC(S.rider.i) + END; + IF S.rider.i < LEN(S.rider.s$) THEN + S.start := S.rider.i; + IF IsDigit(S.rider.s[S.rider.i]) THEN + S.type := TMEOT (* XXX *) + ELSIF IsLetter(S.rider.s[S.rider.i]) THEN + S.type := TMString; + j := 0; + WHILE (S.rider.i < LEN(S.rider.s$)) & (IsLetter(S.rider.s[S.rider.i]) OR IsDigit(S.rider.s[S.rider.i])) DO + S.string[j] := S.rider.s[S.rider.i]; + INC(j); + INC(S.rider.i) + END; + S.string[j] := 0X + ELSE + S.type := TMChar; + S.char := S.rider.s[S.rider.i]; + INC(S.rider.i) + END + ELSE + S.type := TMEOT + END + END Scan; + + PROCEDURE ParseExt (IN S: Scanner; OUT ext: Files.Name); + VAR ch: CHAR; i: INTEGER; + BEGIN + ext := ""; + S.rider.ReadPrevChar(ch); + IF ch = "." THEN + S.rider.ReadChar(ch); + i := 0; + WHILE (ch # 20X) & (ch # 9X) DO + ext[i] := ch; + INC(i); + S.rider.ReadChar(ch) + END; + ext[i] := 0X + ELSIF (ch # 20X) & (ch # 9X) THEN + WriteSString("Invalid character '");WriteChar(ch); WriteSString("' for file name."); + WriteLn; FlushW; error := TRUE + END; + S.SetPos(S.rider.Pos()) + END ParseExt; + + PROCEDURE ParseModList (S: Scanner; end: INTEGER); + VAR mod: Module; + BEGIN + WHILE (S.start < end) & (S.type = TMString) DO + NEW(mod); mod.fileName := S.string$; + mod.next := modList; modList := mod; + S.Scan; + WHILE (S.start < end) & (S.type = TMChar) & + ((S.char = "*") OR (S.char = "+") OR (S.char = "$") OR (S.char = "#")) DO + IF S.char = "*" THEN mod.dll := TRUE + ELSIF S.char = "+" THEN kernel := mod + ELSIF S.char = "$" THEN main := mod + ELSE mod.intf := TRUE; + ASSERT(isDll, 126); + IF ~isDll THEN + WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll."); + WriteLn; FlushW; error := TRUE + END + END; + S.Scan + END + END + END ParseModList; + + PROCEDURE LinkIt (IN txt: ARRAY OF CHAR); + VAR S: Scanner; name, ext: Files.Name; end: INTEGER; + BEGIN + doWrite := TRUE; + headerstrtab.tab[0] := 0X; + headerstrtab.cur := 1; + dynstrtab.tab[0] := 0X; + dynstrtab.cur := 1; + relTextTab.cur := 0; + relRodataTab.cur := 0; + ResetHashtab; + ResetNeededIdx; + modList := NIL; kernel := NIL; main := NIL; + last := NIL; impg := NIL; impd := NIL; + firstExp := NIL; lastExp := NIL; + (* Dialog.ShowStatus("linking"); *) + Console.WriteStr("linking"); Console.WriteLn; + error := FALSE; modList := NIL; + + (* + IF DevCommanders.par = NIL THEN RETURN END; + S.ConnectTo(DevCommanders.par.text); + S.SetPos(DevCommanders.par.beg); + end := DevCommanders.par.end; + DevCommanders.par := NIL; + *) + + S.ConnectTo(txt); + S.SetPos(0); + end := LEN(txt$); + + S.Scan; + + IF S.type = TMString THEN + name := S.string$; + ext := ""; + ParseExt(S, ext); S.Scan; + IF ~error THEN + MakeSoName(name, ext); + IF (S.type = TMChar) & (S.char = ":") THEN S.Scan; + IF (S.type = TMChar) & (S.char = "=") THEN S.Scan; + ParseModList(S, end); + ReadHeaders; + soName := SHORT(name$); + IF ~error THEN + WriteOut + END; + IF ~error THEN + WriteString("Library " + name + " written: "); + WriteInt(Out.Length()); WriteString(" "); WriteInt(text.size) + END + ELSE + error := TRUE; + WriteString(" := missing") + END + ELSE + error := TRUE; + WriteString(" := missing") + END; + WriteLn; FlushW + END + END; + (* IF error THEN Dialog.ShowStatus("Failed to write library") ELSE Dialog.ShowStatus("Ok") END; *) + IF error THEN Console.WriteStr("Failed to write library"); Console.WriteLn ELSE Console.WriteStr("Ok"); Console.WriteLn END; + S.ConnectTo(""); + modList := NIL; kernel := NIL; main := NIL; firstExp := NIL; lastExp := NIL; + last := NIL; impg := NIL; impd := NIL; code := NIL + END LinkIt; + +(* + exes are not supported + + PROCEDURE Link*; + BEGIN + HALT(126); + isDll := FALSE; isStatic := FALSE; + LinkIt + END Link; + + PROCEDURE LinkExe*; + BEGIN + HALT(126); + isDll := FALSE; isStatic := TRUE; + LinkIt + END LinkExe; +*) + + PROCEDURE LinkDll* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := TRUE; isStatic := TRUE; + LinkIt(txt) + END LinkDll; + + PROCEDURE LinkDynDll* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := TRUE; isStatic := FALSE; + LinkIt(txt) + END LinkDynDll; + +BEGIN + newRec := "NewRec"; newArr := "NewArr" +END Dev0ElfLinker. + +LinTestSo LinTestSo2 LinKernel + +DevElfLinker.LinkDynDll libtestbb.so := LinKernel+$ LinTestSo2 LinTestSo# ~ +DevElfLinker.LinkDll libtestbb.so := LinTestSo2 LinTestSo# ~ + diff --git a/Trurl-based/Dev0/Mod/Interp.txt b/Trurl-based/Dev0/Mod/Interp.txt new file mode 100644 index 0000000..f4ab977 --- /dev/null +++ b/Trurl-based/Dev0/Mod/Interp.txt @@ -0,0 +1,56 @@ +MODULE Dev0Interp; + + (* + A. V. Shiryaev, 2012.10 + *) + + IMPORT Console, HostConsole (* required *), Strings, Dialog, StdInterpreter (* required (Dialog.SetCallHook) *); + + PROCEDURE WriteInt (x: INTEGER); + VAR s: ARRAY 16 OF CHAR; + BEGIN + Strings.IntToString(x, s); + Console.WriteStr(s) + END WriteInt; + + PROCEDURE Call (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + res: BOOLEAN; + BEGIN + i := 0; + WHILE (i < LEN(s)) & (s[i] # 0AX) & (s[i] # 0DX) & (s[i] # 0X) DO + INC(i) + END; + IF (i < LEN(s)) & (s[i] # 0X) THEN + IF (i > 0) & (s[0] # '#') THEN + s[i] := 0X; + Dialog.Call(s, "", i); + IF i = 0 THEN + res := TRUE + ELSE + WriteInt(i); Console.WriteLn; + res := FALSE (* stop on Dialog.Call error *) + END + ELSE (* skip empty strings and comments *) + res := TRUE + END + ELSE (* end of input *) + res := FALSE + END; + RETURN res + END Call; + + PROCEDURE Init; + VAR s: ARRAY 1024 OF CHAR; + BEGIN + (* Dialog.SetLanguage("", FALSE); *) + + Console.ReadLn(s); + WHILE Call(s) DO + Console.ReadLn(s) + END + END Init; + +BEGIN + Init +END Dev0Interp. diff --git a/Trurl-based/Dev0/Mod/Linker.odc b/Trurl-based/Dev0/Mod/Linker.odc new file mode 100644 index 0000000..d07ac20 Binary files /dev/null and b/Trurl-based/Dev0/Mod/Linker.odc differ diff --git a/Trurl-based/Dev0/Mod/Linker.txt b/Trurl-based/Dev0/Mod/Linker.txt new file mode 100644 index 0000000..874bf1a --- /dev/null +++ b/Trurl-based/Dev0/Mod/Linker.txt @@ -0,0 +1,1779 @@ +MODULE Dev0Linker; + + (* THIS IS TEXT COPY OF Linker.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Files, (* Dates, Dialog, *) Strings, + (* TextModels, TextViews, TextMappers, + Log := StdLog, DevCommanders *) Console; + + CONST + NewRecFP = 4E27A847H; + NewArrFP = 76068C78H; + + ImageBase = 00400000H; + ObjAlign = 1000H; + FileAlign = 200H; + HeaderSize = 400H; + + FixLen = 30000; + + OFdir = "Code"; + SYSdir = "System"; + RsrcDir = "Rsrc"; + WinDir = "Win"; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + mInternal = 1; mReadonly = 2; mExported = 4; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; + + (* mod desc fields *) + modOpts = 4; modRefcnt = 8; modTerm = 40; modNames = 84; modImports = 92; modExports = 96; + + + (* A. V. Shiryaev: Scanner *) + TMChar = 0; TMString = 1; TMInt = 2; TMEOT = 3; + + TYPE + Name = ARRAY 40 OF SHORTCHAR; + Export = POINTER TO RECORD + next: Export; + name: Name; + adr: INTEGER + END; + Resource = POINTER TO RECORD + next, local: Resource; + typ, id, lid, size, pos, x, y: INTEGER; + opts: SET; + file: Files.File; + name: Files.Name + END; + Module = POINTER TO RECORD + next: Module; + name: Files.Name; + file: Files.File; + hs, ms, ds, cs, vs, ni, ma, ca, va: INTEGER; + dll, intf: BOOLEAN; + exp: Export; + imp: POINTER TO ARRAY OF Module; + data: POINTER TO ARRAY OF BYTE; + END; + + (* A. V. Shiryaev: Scanner *) + ScanRider = RECORD + s: POINTER TO ARRAY OF CHAR; + i: INTEGER + END; + Scanner = RECORD + rider: ScanRider; + start, type: INTEGER; + + string: ARRAY 100 OF CHAR; + char: CHAR; + int: INTEGER + END; + + VAR +(* + W: TextMappers.Formatter; +*) + Out: Files.File; + R: Files.Reader; + Ro: Files.Writer; + error, isDll, isStatic, comLine: BOOLEAN; + modList, kernel, main, last, impg, impd: Module; + numMod, lastTerm: INTEGER; + resList: Resource; + numType, resHSize: INTEGER; + numId: ARRAY 32 OF INTEGER; + rsrcName: ARRAY 16 OF CHAR; (* name of resource file *) + firstExp, lastExp: Export; + entryPos, isPos, fixPos, himpPos, hexpPos, hrsrcPos, termPos: INTEGER; + codePos, dataPos, conPos, rsrcPos, impPos, expPos, relPos: INTEGER; + CodeSize, DataSize, ConSize, RsrcSize, ImpSize, ImpHSize, ExpSize, RelocSize, DllSize: INTEGER; + CodeRva, DataRva, ConRva, RsrcRva, ImpRva, ExpRva, RelocRva, ImagesSize: INTEGER; + CodeBase, DataBase, ConBase, maxCode, numImp, numExp, noffixup, timeStamp: INTEGER; + newRec, newArr: Name; + fixups: POINTER TO ARRAY OF INTEGER; + code: POINTER TO ARRAY OF BYTE; + atab: POINTER TO ARRAY OF INTEGER; + ntab: POINTER TO ARRAY OF SHORTCHAR; + + (* A. V. Shiryaev: Console *) + + PROCEDURE WriteString (s: ARRAY OF CHAR); + BEGIN + Console.WriteStr(s) + END WriteString; + + PROCEDURE WriteChar (c: CHAR); + VAR s: ARRAY 2 OF CHAR; + BEGIN + s[0] := c; s[1] := 0X; + Console.WriteStr(s) + END WriteChar; + + PROCEDURE WriteSString (ss: ARRAY OF SHORTCHAR); + BEGIN + Console.WriteStr(ss$) + END WriteSString; + + PROCEDURE WriteInt (x: INTEGER); + VAR s: ARRAY 16 OF CHAR; + BEGIN + Strings.IntToString(x, s); + Console.WriteStr(s) + END WriteInt; + + PROCEDURE WriteLn; + BEGIN + Console.WriteLn + END WriteLn; + + PROCEDURE FlushW; + BEGIN + END FlushW; + +(* + PROCEDURE TimeStamp (): INTEGER; (* seconds since 1.1.1970 00:00:00 *) + VAR a: INTEGER; t: Dates.Time; d: Dates.Date; + BEGIN + Dates.GetTime(t); Dates.GetDate(d); + a := 12 * (d.year - 70) + d.month - 3; + a := a DIV 12 * 1461 DIV 4 + (a MOD 12 * 153 + 2) DIV 5 + d.day + 59; + RETURN ((a * 24 + t.hour) * 60 + t.minute) * 60 + t.second; + END TimeStamp; +*) + + PROCEDURE ThisFile (modname: ARRAY OF CHAR): Files.File; + VAR dir, name: Files.Name; loc: Files.Locator; f: Files.File; + BEGIN + Kernel.SplitName(modname, dir, name); + Kernel.MakeFileName(name, Kernel.objType); + loc := Files.dir.This(dir); loc := loc.This(OFdir); + f := Files.dir.Old(loc, name, TRUE); + IF (f = NIL) & (dir = "") THEN + loc := Files.dir.This(SYSdir); loc := loc.This(OFdir); + f := Files.dir.Old(loc, name, TRUE) + END; + RETURN f + END ThisFile; + + PROCEDURE ThisResFile (VAR name: Files.Name): Files.File; + VAR loc: Files.Locator; f: Files.File; + BEGIN + f := Files.dir.Old(Files.dir.This(RsrcDir), name, TRUE); + IF f = NIL THEN + loc := Files.dir.This(WinDir); loc := loc.This(RsrcDir); + f := Files.dir.Old(loc, name, TRUE); + IF f = NIL THEN + f := Files.dir.Old(Files.dir.This(""), name, TRUE) + END + END; + RETURN f + END ThisResFile; + + PROCEDURE Read2 (VAR x: INTEGER); + VAR b: BYTE; + BEGIN + R.ReadByte(b); x := b MOD 256; + R.ReadByte(b); x := x + 100H * (b MOD 256) + END Read2; + + PROCEDURE Read4 (VAR x: INTEGER); + VAR b: BYTE; + BEGIN + R.ReadByte(b); x := b MOD 256; + R.ReadByte(b); x := x + 100H * (b MOD 256); + R.ReadByte(b); x := x + 10000H * (b MOD 256); + R.ReadByte(b); x := x + 1000000H * b + END Read4; + + PROCEDURE ReadName (VAR name: ARRAY OF SHORTCHAR); + VAR i: INTEGER; b: BYTE; + BEGIN i := 0; + REPEAT + R.ReadByte(b); name[i] := SHORT(CHR(b)); INC(i) + UNTIL b = 0 + END ReadName; + + PROCEDURE RNum (VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; R.ReadByte(b); + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); R.ReadByte(b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y + END RNum; + + PROCEDURE WriteCh (ch: SHORTCHAR); + BEGIN + Ro.WriteByte(SHORT(ORD(ch))) + END WriteCh; + + PROCEDURE Write2 (x: INTEGER); + BEGIN + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))) + END Write2; + + PROCEDURE Write4 (x: INTEGER); + BEGIN + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; + Ro.WriteByte(SHORT(SHORT(x MOD 256))) + END Write4; + + PROCEDURE WriteName (s: ARRAY OF SHORTCHAR; len: SHORTINT); + VAR i: SHORTINT; + BEGIN i := 0; + WHILE s[i] # 0X DO Ro.WriteByte(SHORT(ORD(s[i]))); INC(i) END; + WHILE i < len DO Ro.WriteByte(0); INC(i) END + END WriteName; + + PROCEDURE Reloc (a: INTEGER); + VAR p: POINTER TO ARRAY OF INTEGER; i: INTEGER; + BEGIN + IF noffixup >= LEN(fixups) THEN + NEW(p, 2 * LEN(fixups)); + i := 0; WHILE i < LEN(fixups) DO p[i] := fixups[i]; INC(i) END; + fixups := p + END; + fixups[noffixup] := a; INC(noffixup) +(* + ELSE + IF ~error THEN W.WriteSString(" too many fixups") END; + error := TRUE + END +*) + END Reloc; + + PROCEDURE Put (mod: Module; a, x: INTEGER); + BEGIN + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; + mod.data[a] := SHORT(SHORT(x)) + END Put; + + PROCEDURE Get (mod: Module; a: INTEGER; VAR x: INTEGER); + BEGIN + x := ((mod.data[a + 3] * 256 + + (mod.data[a + 2] MOD 256)) * 256 + + (mod.data[a + 1] MOD 256)) * 256 + + (mod.data[a] MOD 256) + END Get; + + PROCEDURE GenName (VAR from, to: ARRAY OF SHORTCHAR; ext: ARRAY OF SHORTCHAR); + VAR i, j: INTEGER; + BEGIN + i := 0; + WHILE from[i] # 0X DO to[i] := from[i]; INC(i) END; + IF ext # "" THEN + to[i] := "."; INC(i); j := 0; + WHILE ext[j] # 0X DO to[i] := ext[j]; INC(i); INC(j) END + END; + to[i] := 0X + END GenName; + + PROCEDURE Fixup0 (link, adr: INTEGER); + VAR offset, linkadr, t, n, x: INTEGER; + BEGIN + WHILE link # 0 DO + RNum(offset); + WHILE link # 0 DO + IF link > 0 THEN + n := (code[link] MOD 256) + (code[link+1] MOD 256) * 256 + code[link+2] * 65536; + t := code[link+3]; linkadr := CodeBase + impg.ca + link + ELSE + n := (impg.data[-link] MOD 256) + (impg.data[-link+1] MOD 256) * 256 + impg.data[-link+2] * 65536; + t := impg.data[-link+3]; linkadr := ConBase + impg.ma - link + END; + IF t = absolute THEN x := adr + offset + ELSIF t = relative THEN x := adr + offset - linkadr - 4 + ELSIF t = copy THEN Get(impd, adr + offset - ConBase - impd.ma, x) + ELSIF t = table THEN x := adr + n; n := link + 4 + ELSIF t = tableend THEN x := adr + n; n := 0 + ELSE HALT(99) + END; + IF link > 0 THEN + code[link] := SHORT(SHORT(x)); + code[link+1] := SHORT(SHORT(x DIV 100H)); + code[link+2] := SHORT(SHORT(x DIV 10000H)); + code[link+3] := SHORT(SHORT(x DIV 1000000H)) + ELSE + link := -link; + impg.data[link] := SHORT(SHORT(x)); + impg.data[link+1] := SHORT(SHORT(x DIV 100H)); + impg.data[link+2] := SHORT(SHORT(x DIV 10000H)); + impg.data[link+3] := SHORT(SHORT(x DIV 1000000H)) + END; + IF (t # relative) & ((t # copy) OR (x DIV 65536 # 0)) THEN Reloc(linkadr) END; + link := n + END; + RNum(link) + END + END Fixup0; + + PROCEDURE Fixup (adr: INTEGER); + VAR link: INTEGER; + BEGIN + RNum(link); Fixup0(link, adr) + END Fixup; + + PROCEDURE CheckDllImports (mod: Module); + VAR i, x, y: INTEGER; name: Name; imp: Module; exp: Export; + + PROCEDURE SkipLink; + VAR a: INTEGER; + BEGIN + RNum(a); + WHILE a # 0 DO RNum(a); RNum(a) END + END SkipLink; + + BEGIN + R := mod.file.NewReader(R); + R.SetPos(mod.hs + mod.ms + mod.ds + mod.cs); + SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; i := 0; + WHILE i < mod.ni DO + imp := mod.imp[i]; + IF imp # NIL THEN + RNum(x); + WHILE x # 0 DO + ReadName(name); RNum(y); + IF x = mVar THEN SkipLink; + IF imp.dll THEN + WriteString("variable ("); + WriteString(imp.name); WriteChar("."); + WriteSString(name); + WriteString(") imported from DLL in "); + WriteString(mod.name); + WriteLn; FlushW; error := TRUE; + RETURN + END + ELSIF x = mTyp THEN RNum(y); + IF imp.dll THEN + RNum(y); + IF y # 0 THEN + WriteString("type descriptor ("); + WriteString(imp.name); WriteChar("."); + WriteSString(name); + WriteString(") imported from DLL in "); + WriteString(mod.name); + WriteLn; FlushW; error := TRUE; + RETURN + END + ELSE SkipLink + END + ELSIF x = mProc THEN + IF imp.dll THEN + SkipLink; exp := imp.exp; + WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END; + IF exp = NIL THEN + NEW(exp); exp.name := name$; + exp.next := imp.exp; imp.exp := exp; INC(DllSize, 6) + END + END + END; + RNum(x) + END + END; + INC(i) + END + END CheckDllImports; + + PROCEDURE ReadHeaders; + VAR mod, im, t: Module; x, i: INTEGER; impdll: BOOLEAN; exp: Export; name: Name; + BEGIN + mod := modList; modList := NIL; numMod := 0; + WHILE mod # NIL DO (* reverse mod list & count modules *) + IF ~mod.dll THEN INC(numMod) END; + t := mod; mod := t.next; t.next := modList; modList := t + END; + IF isStatic THEN + IF isDll THEN + (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; { call body; } jp L2 *) + (* L1: cmp [12, esp], 0; jne L2; { call term; } *) + (* L2: pop ebx; mov aex,1; ret 12 *) + CodeSize := 42 + 10 * numMod + ELSE + (* push ebx; push ebx; push ebx; mov ebx, modlist; { call body; } { call term; } *) + (* pop ebx; pop ebx; pop ebx; ret *) + CodeSize := 12 + 10 * numMod + END + ELSE + IF isDll THEN + (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; call main; jp L2 *) + (* L1: cmp [12, esp], 0; jne L2; call mainTerm; *) + (* L2: pop ebx; mov aex,1; ret 12 *) + CodeSize := 41 + ELSE + (* mov ebx, modlist; jmp main *) + CodeSize := 10 + END + END; +(* + IF isDll THEN + CodeSize := 24 (* push ebx, esi, edi; mov bx, modlist; call main; pop edi, esi, ebx; mov aex,1; ret 12 *) + ELSE + CodeSize := 10 (* mov bx, modlist; jmp main *) + END +*) + DataSize := 0; ConSize := 0; + ImpSize := 0; ImpHSize := 0; ExpSize := 0; + RelocSize := 0; DllSize := 0; noffixup := 0; maxCode := 0; numImp := 0; numExp := 0; + mod := modList; + WHILE mod # NIL DO + IF ~mod.dll THEN + mod.file := ThisFile(mod.name); + IF mod.file # NIL THEN + R := mod.file.NewReader(R); R.SetPos(0); Read4(x); + IF x = 6F4F4346H THEN + Read4(x); + Read4(mod.hs); Read4(mod.ms); Read4(mod.ds); Read4(mod.cs); + Read4(mod.vs); RNum(mod.ni); ReadName(name); impdll := FALSE; + IF mod.ni > 0 THEN + NEW(mod.imp, mod.ni); x := 0; + WHILE x < mod.ni DO + ReadName(name); + IF name = "$$" THEN + IF (mod # kernel) & (kernel # NIL) THEN + mod.imp[x] := kernel + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; error := TRUE + END + ELSIF name[0] = "$" THEN + i := 1; + WHILE name[i] # 0X DO name[i-1] := name[i]; INC(i) END; + name[i-1] := 0X; impdll := TRUE; im := modList; + WHILE (im # mod) & (im.name # name) DO im := im.next END; + IF (im = NIL) OR ~im.dll THEN + NEW(im); im.next := modList; modList := im; + im.name := name$; + im.dll := TRUE + END; + mod.imp[x] := im; + ELSE + im := modList; + WHILE (im # mod) & (im.name # name) DO im := im.next END; + IF im # mod THEN + mod.imp[x] := im; + ELSE + WriteSString(name); + WriteString(" not present (imported in "); + WriteString(mod.name); WriteChar(")"); + WriteLn; FlushW; error := TRUE + END + END; + INC(x) + END + END; + IF impdll & ~error THEN CheckDllImports(mod) END; + mod.ma := ConSize; INC(ConSize, mod.ms + mod.ds); + mod.va := DataSize; INC(DataSize, mod.vs); + mod.ca := CodeSize; INC(CodeSize, mod.cs); + IF mod.cs > maxCode THEN maxCode := mod.cs END + ELSE + WriteString(mod.name); WriteString(": wrong file type"); + WriteLn; FlushW; error := TRUE + END; + mod.file.Close; mod.file := NIL + ELSE + WriteString(mod.name); WriteString(" not found"); + WriteLn; FlushW; error := TRUE + END; + last := mod + END; + mod := mod.next + END; + IF ~isStatic & (main = NIL) THEN + WriteSString("no main module specified"); WriteLn; + FlushW; error := TRUE + END; + (* calculate rva's *) + IF DataSize = 0 THEN DataSize := 1 END; + CodeRva := ObjAlign; + DataRva := CodeRva + (CodeSize + DllSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + ConRva := DataRva + (DataSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + RsrcRva := ConRva + (ConSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + CodeBase := ImageBase + CodeRva; + DataBase := ImageBase + DataRva; + ConBase := ImageBase + ConRva; + (* write dll export adresses *) + mod := modList; x := 0; + WHILE mod # NIL DO + IF mod.dll THEN + exp := mod.exp; INC(ImpSize, 20); + WHILE exp # NIL DO exp.adr := x; INC(x, 6); exp := exp.next END + END; + mod := mod.next + END; + ASSERT(x = DllSize); INC(ImpSize, 20); (* sentinel *) + END ReadHeaders; + + PROCEDURE MenuSize (r: Resource): INTEGER; + VAR s, i: INTEGER; + BEGIN + s := 0; + WHILE r # NIL DO + INC(s, 2); + IF r.local = NIL THEN INC(s, 2) END; + i := 0; WHILE r.name[i] # 0X DO INC(s, 2); INC(i) END; + INC(s, 2); + s := s + MenuSize(r.local); + r := r.next + END; + RETURN s + END MenuSize; + + PROCEDURE PrepResources; + VAR res, r, s: Resource; n, i, j, t, x: INTEGER; loc: Files.Locator; + BEGIN + r := resList; + WHILE r # NIL DO + IF r.lid = 0 THEN r.lid := 1033 END; + IF r.name = "MENU" THEN + r.typ := 4; r.size := 4 + MenuSize(r.local); + ELSIF r.name = "ACCELERATOR" THEN + r.typ := 9; r.size := 0; s := r.local; + WHILE s # NIL DO INC(r.size, 8); s := s.next END; + ELSE + r.file := ThisResFile(r.name); + IF r.file # NIL THEN + IF r.typ = -1 THEN (* typelib *) + r.typ := 0; r.size := r.file.Length(); r.pos := 0; rsrcName := "TYPELIB" + ELSE + R := r.file.NewReader(R); R.SetPos(0); Read2(n); + IF n = 4D42H THEN (* bitmap *) + Read4(n); r.typ := 2; r.size := n - 14; r.pos := 14; + ELSE + Read2(x); + IF x = 1 THEN (* icon *) + Read2(n); r.typ := 14; r.size := 6 + 14 * n; r.pos := 0; i := 0; + WHILE i < n DO + NEW(s); s.typ := 3; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$; + Read4(x); Read4(x); Read4(s.size); Read2(s.pos); Read2(x); + s.next := resList; resList := s; + INC(i) + END + ELSIF x = 2 THEN (* cursor *) + Read2(n); r.typ := 12; r.size := 6 + 14 * n; r.pos := 0; i := 0; + WHILE i < n DO + NEW(s); s.typ := 1; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$; + Read4(x); Read2(s.x); Read2(s.y); Read4(s.size); INC(s.size, 4); Read2(s.pos); Read2(x); + s.next := resList; resList := s; + INC(i) + END + ELSE + Read4(n); + IF (x = 0) & (n = 20H) THEN (* resource file *) + Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); (* 32 bit marker *) + Read4(r.size); Read4(n); Read2(i); + IF i = 0FFFFH THEN + Read2(j); + IF (j >= 4) & ((j <= 11) OR (j = 16)) THEN + r.typ := j; r.pos := n + 32; + ELSE + WriteString(r.name); WriteString(": invalid type"); WriteLn; + FlushW; error := TRUE + END + ELSE + j := 0; + WHILE i # 0 DO rsrcName[j] := CHR(i); INC(j); Read2(i) END; + rsrcName[j] := 0X; + r.typ := 0; r.pos := n + 32 + END + ELSE + WriteString(r.name); WriteString(": unknown type"); WriteLn; + FlushW; error := TRUE + END + END + END + END; + r.file.Close; r.file := NIL + ELSE + WriteString(r.name); WriteString(" not found"); WriteLn; + FlushW; error := TRUE + END + END; + r := r.next + END; + res := resList; resList := NIL; (* sort resources *) + WHILE res # NIL DO + r := res; res := res.next; + IF (resList = NIL) OR (r.typ < resList.typ) OR (r.typ = resList.typ) & ((r.id < resList.id) OR (r.id = resList.id) & (r.lid < resList.lid)) + THEN + r.next := resList; resList := r + ELSE + s := resList; + WHILE (s.next # NIL) & (r.typ >= s.next.typ) + & ((r.typ # s.next.typ) OR (r.id >= s.next.id) & ((r.id # s.next.id) OR (r.lid >= s.next.lid))) DO s := s.next END; + r.next := s.next; s.next := r + END + END; + r := resList; numType := 0; resHSize := 16; t := 0; n := 0; (* get resource size *) + WHILE t < LEN(numId) DO numId[t] := 0; INC(t) END; + WHILE r # NIL DO + INC(numType); INC(resHSize, 24); t := r.typ; + WHILE (r # NIL) & (r.typ = t) DO + INC(numId[t]); INC(resHSize, 24); i := r.id; + WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO + INC(resHSize, 24); INC(n, (r.size + 3) DIV 4 * 4); r := r.next + END + END + END; + IF numId[0] > 0 THEN INC(n, (LEN(rsrcName$) + 1) * 2) END; + RsrcSize := resHSize + n; + ImpRva := RsrcRva + (RsrcSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign + END PrepResources; + + PROCEDURE WriteHeader(VAR name: Files.Name); + BEGIN + Out := Files.dir.New(Files.dir.This(""), Files.ask); Ro := Out.NewWriter(Ro); Ro.SetPos(0); + + (* DOS header *) + Write4(905A4DH); Write4(3); Write4(4); Write4(0FFFFH); + Write4(0B8H); Write4(0); Write4(40H); Write4(0); + Write4(0); Write4(0); Write4(0); Write4(0); + Write4(0); Write4(0); Write4(0); Write4(80H); + Write4(0EBA1F0EH); Write4(0CD09B400H); Write4(4C01B821H); Write2(21CDH); + WriteName("This program cannot be run in DOS mode.", 39); + WriteCh(0DX); WriteCh(0DX); WriteCh(0AX); + Write4(24H); Write4(0); + + (* Win32 header *) + WriteName("PE", 4); (* signature bytes *) + Write2(014CH); (* cpu type (386) *) + IF isDll THEN + Write2(7); (* 7 objects *) + ELSE + Write2(6); (* 6 objects *) + END; + Write4(timeStamp); (* time/date *) + Write4(0); Write4(0); + Write2(0E0H); (* NT header size *) + IF isDll THEN + Write2(0A38EH); (* library image flags *) + ELSE + Write2(838EH); (* program image flags *) + END; + Write2(10BH); (* magic (normal ececutable file) *) + Write2(0301H); (* linker version !!! *) + Write4(CodeSize); (* code size *) + Write4(ConSize); (* initialized data size *) + Write4(DataSize); (* uninitialized data size *) + entryPos := Ro.Pos(); + Write4(0); (* entry point *) (* !!! *) + Write4(CodeRva); (* base of code *) + Write4(ConRva); (* base of data *) + Write4(400000H); (* image base *) + Write4(ObjAlign); (* object align *) + Write4(FileAlign); (* file align *) + Write4(3); (* OS version *) + Write4(4); (* user version *) + Write4(4); (* subsys version *) (* mf 14.3.04: value changed from 0A0003H to 4. Corrects menubar pixel bug on Windows XP *) + Write4(0); + isPos := Ro.Pos(); + Write4(0); (* image size *) (* !!! *) + Write4(HeaderSize); (* header size !!! *) + Write4(0); (* checksum *) + IF comLine THEN + Write2(3) (* dos subsystem *) + ELSE + Write2(2) (* gui subsystem *) + END; + Write2(0); (* dll flags *) + Write4(200000H); (* stack reserve size *) + Write4(10000H); (* stack commit size *) + IF isDll THEN + Write4(00100000H); (* heap reserve size *) + ELSE + Write4(00400000H); (* heap reserve size *) + END; + Write4(10000H); (* heap commit size *) + Write4(0); + Write4(16); (* num of rva/sizes *) + hexpPos := Ro.Pos(); + Write4(0); Write4(0); (* export table *) + himpPos := Ro.Pos(); + Write4(0); Write4(0); (* import table *) (* !!! *) + hrsrcPos := Ro.Pos(); + Write4(0); Write4(0); (* resource table *) (* !!! *) + Write4(0); Write4(0); (* exception table *) + Write4(0); Write4(0); (* security table *) + fixPos := Ro.Pos(); + Write4(0); Write4(0); (* fixup table *) (* !!! *) + Write4(0); Write4(0); (* debug table *) + Write4(0); Write4(0); (* image description *) + Write4(0); Write4(0); (* machine specific *) + Write4(0); Write4(0); (* thread local storage *) + Write4(0); Write4(0); (* ??? *) + Write4(0); Write4(0); (* ??? *) + Write4(0); Write4(0); (* ??? *) + Write4(0); Write4(0); (* ??? *) + Write4(0); Write4(0); (* ??? *) + Write4(0); Write4(0); (* ??? *) + + (* object directory *) + WriteName(".text", 8); (* code object *) + Write4(0); (* object size (always 0) *) + codePos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(60000020H); (* flags: code, exec, read *) + + WriteName(".var", 8); (* variable object *) + Write4(0); (* object size (always 0) *) + dataPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) (* zero! (noinit) *) + Write4(0); Write4(0); Write4(0); + Write4(0C0000080H); (* flags: noinit, read, write *) + + WriteName(".data", 8); (* constant object *) + Write4(0); (* object size (always 0) *) + conPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(0C0000040H); (* flags: data, read, write *) + + WriteName(".rsrc", 8); (* resource object *) + Write4(0); (* object size (always 0) *) + rsrcPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(0C0000040H); (* flags: data, read, write *) + + WriteName(".idata", 8); (* import object *) + Write4(0); (* object size (always 0) *) + impPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(0C0000040H); (* flags: data, read, write *) + + IF isDll THEN + WriteName(".edata", 8); (* export object *) + Write4(0); (* object size (always 0) *) + expPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(0C0000040H); (* flags: data, read, write *) + END; + + WriteName(".reloc", 8); (* relocation object *) + Write4(0); (* object size (always 0) *) + relPos := Ro.Pos(); + Write4(0); (* object rva *) + Write4(0); (* physical size *) + Write4(0); (* physical offset *) + Write4(0); Write4(0); Write4(0); + Write4(42000040H); (* flags: data, read, ? *) + END WriteHeader; + + PROCEDURE SearchObj (mod: Module; VAR name: ARRAY OF SHORTCHAR; m, fp, opt: INTEGER; VAR adr: INTEGER); + VAR dir, len, ntab, f, id, l, r, p, n, i, j: INTEGER; nch, och: SHORTCHAR; + BEGIN + Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4); + Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma); + IF name # "" THEN + l := 0; r := len; + WHILE l < r DO (* binary search *) + n := (l + r) DIV 2; p := dir + n * 16; + Get(mod, p + 8, id); + i := 0; j := ntab + id DIV 256; nch := name[0]; och := SHORT(CHR(mod.data[j])); + WHILE (nch = och) & (nch # 0X) DO INC(i); INC(j); nch := name[i]; och := SHORT(CHR(mod.data[j])) END; + IF och = nch THEN + IF id MOD 16 = m THEN Get(mod, p, f); + IF m = mTyp THEN + IF ODD(opt) THEN Get(mod, p + 4, f) END; + IF (opt > 1) & (id DIV 16 MOD 16 # mExported) THEN + WriteString(mod.name); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name); + WriteString(" has wrong visibility"); WriteLn; error := TRUE + END; + Get(mod, p + 12, adr) + ELSIF m = mVar THEN + Get(mod, p + 4, adr); INC(adr, DataBase + mod.va) + ELSIF m = mProc THEN + Get(mod, p + 4, adr); INC(adr, CodeBase + mod.ca) + END; + IF f # fp THEN + WriteString(mod.name); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name); + WriteString(" has wrong fprint"); WriteLn; error := TRUE + END + ELSE + WriteString(mod.name); WriteChar("."); WriteSString(name); + WriteString(" imported from "); WriteString(impg.name); + WriteString(" has wrong class"); WriteLn; error := TRUE + END; + RETURN + END; + IF och < nch THEN l := n + 1 ELSE r := n END + END; + WriteString(mod.name); WriteChar("."); WriteSString(name); + WriteString(" not found (imported from "); WriteString(impg.name); + WriteChar(")"); WriteLn; error := TRUE + ELSE (* anonymous type *) + WHILE len > 0 DO + Get(mod, dir + 4, f); Get(mod, dir + 8, id); + IF (f = fp) & (id MOD 16 = mTyp) & (id DIV 256 = 0) THEN + Get(mod, dir + 12, adr); RETURN + END; + DEC(len); INC(dir, 16) + END; + WriteString("anonymous type in "); WriteString(mod.name); + WriteString(" not found"); WriteLn; error := TRUE + END + END SearchObj; + + PROCEDURE CollectExports (mod: Module); + VAR dir, len, ntab, id, i, j, n: INTEGER; e, exp: Export; + BEGIN + Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4); + Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma); n := 0; + WHILE n < len DO + Get(mod, dir + 8, id); + IF (id DIV 16 MOD 16 # mInternal) & ((id MOD 16 = mProc) OR (id MOD 16 = mVar))THEN (* exported procedure & var *) + NEW(exp); + i := 0; j := ntab + id DIV 256; + WHILE mod.data[j] # 0 DO exp.name[i] := SHORT(CHR(mod.data[j])); INC(i); INC(j) END; + exp.name[i] := 0X; + Get(mod, dir + 4, exp.adr); + IF id MOD 16 = mProc THEN INC(exp.adr, CodeRva + mod.ca) + ELSE ASSERT(id MOD 16 = mVar); INC(exp.adr, DataRva + mod.va) + END; + IF (firstExp = NIL) OR (exp.name < firstExp.name) THEN + exp.next := firstExp; firstExp := exp; + IF lastExp = NIL THEN lastExp := exp END + ELSE + e := firstExp; + WHILE (e.next # NIL) & (exp.name > e.next.name) DO e := e.next END; + exp.next := e.next; e.next := exp; + IF lastExp = e THEN lastExp := exp END + END; + INC(numExp); + END; + INC(n); INC(dir, 16) + END + END CollectExports; + + PROCEDURE WriteTermCode (m: Module; i: INTEGER); + VAR x: INTEGER; + BEGIN + IF m # NIL THEN + IF m.dll THEN WriteTermCode(m.next, i) + ELSE + IF isStatic THEN WriteTermCode(m.next, i + 1) END; + Get(m, m.ms + modTerm, x); (* terminator address in mod desc*) + IF x = 0 THEN + WriteCh(005X); Write4(0) (* add EAX, 0 (nop) *) + ELSE + WriteCh(0E8X); Write4(x - lastTerm + 5 * i - CodeBase) (* call term *) + END + END + END + END WriteTermCode; + + PROCEDURE WriteCode; + VAR mod, m: Module; i, x, a, fp, opt: INTEGER; exp: Export; name: Name; + BEGIN + IF isStatic THEN + WriteCh(053X); (* push ebx *) + a := 1; + IF isDll THEN + WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *) + WriteCh(00FX); WriteCh(085X); Write4(10 + 5 * numMod); (* jne L1 *) + INC(a, 11) + ELSE + WriteCh(053X); WriteCh(053X); (* push ebx; push ebx *) + INC(a, 2) + END; + WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + a + 1); (* mov bx, modlist *) + INC(a, 5); m := modList; + WHILE m # NIL DO + IF ~m.dll THEN + WriteCh(0E8X); INC(a, 5); Write4(m.ca - a) (* call body *) + END; + m := m.next + END; + IF isDll THEN + WriteCh(0E9X); Write4(11 + 5 * numMod); (* jp L2 *) + WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *) + WriteCh(00FX); WriteCh(085X); Write4(5 * numMod); (* jne L2 *) + INC(a, 16) + END; + termPos := Ro.Pos(); i := 0; + WHILE i < numMod DO (* nop for call terminator *) + WriteCh(02DX); Write4(0); (* sub EAX, 0 *) + INC(i); INC(a, 5) + END; + lastTerm := a; + WriteCh(05BX); (* L2: pop ebx *) + IF isDll THEN + WriteCh(0B8X); Write4(1); (* mov eax,1 *) + WriteCh(0C2X); Write2(12) (* ret 12 *) + ELSE + WriteCh(05BX); WriteCh(05BX); (* pop ebx; pop ebx *) + WriteCh(0C3X) (* ret *) + END + ELSIF isDll THEN + WriteCh(053X); (* push ebx *) + WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *) + WriteCh(075X); WriteCh(SHORT(CHR(12))); (* jne L1 *) + WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 9); (* mov bx, modlist *) + WriteCh(0E8X); Write4(main.ca - 18); (* call main *) + WriteCh(0EBX); WriteCh(SHORT(CHR(12))); (* jp L2 *) + WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *) + WriteCh(075X); WriteCh(SHORT(CHR(5))); (* jne L2 *) + termPos := Ro.Pos(); + WriteCh(02DX); Write4(0); (* sub EAX, 0 *) (* nop for call terminator *) + lastTerm := 32; + WriteCh(05BX); (* L2: pop ebx *) + WriteCh(0B8X); Write4(1); (* mov eax,1 *) + WriteCh(0C2X); Write2(12) (* ret 12 *) + ELSE + WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 1); (* mov bx, modlist *) + WriteCh(0E9X); Write4(main.ca - 10); (* jmp main *) + END; + NEW(code, maxCode); + mod := modList; + WHILE mod # NIL DO impg := mod; impd := mod; + IF ~mod.dll THEN + mod.file := ThisFile(mod.name); + R := mod.file.NewReader(R); R.SetPos(mod.hs); + NEW(mod.data, mod.ms + mod.ds); + R.ReadBytes(mod.data^, 0, mod.ms + mod.ds); + R.ReadBytes(code^, 0, mod.cs); + RNum(x); + IF x # 0 THEN + IF (mod # kernel) & (kernel # NIL) THEN + SearchObj(kernel, newRec, mProc, NewRecFP, -1, a); Fixup0(x, a) + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; error := TRUE; RETURN + END + END; + RNum(x); + IF x # 0 THEN + IF (mod # kernel) & (kernel # NIL) THEN + SearchObj(kernel, newArr, mProc, NewArrFP, -1, a); Fixup0(x, a) + ELSE + WriteSString("no kernel"); WriteLn; + FlushW; error := TRUE; RETURN + END + END; + Fixup(ConBase + mod.ma); + Fixup(ConBase + mod.ma + mod.ms); + Fixup(CodeBase + mod.ca); + Fixup(DataBase + mod.va); i := 0; + WHILE i < mod.ni DO + m := mod.imp[i]; impd := m; RNum(x); + WHILE x # 0 DO + ReadName(name); RNum(fp); opt := 0; + IF x = mTyp THEN RNum(opt) END; + IF m.dll THEN + IF x = mProc THEN exp := m.exp; + WHILE exp.name # name DO exp := exp.next END; + a := exp.adr + CodeBase + CodeSize + END + ELSE + SearchObj(m, name, x, fp, opt, a) + END; + IF x # mConst THEN Fixup(a) END; + RNum(x) + END; + IF ~m.dll THEN + Get(mod, mod.ms + modImports, x); DEC(x, ConBase + mod.ma); INC(x, 4 * i); + Put(mod, x, ConBase + m.ma + m.ms); (* imp ref *) + Reloc(ConBase + mod.ma + x); + Get(m, m.ms + modRefcnt, x); Put(m, m.ms + modRefcnt, x + 1) (* inc ref count *) + END; + INC(i) + END; + Ro.WriteBytes(code^, 0, mod.cs); + IF mod.intf THEN CollectExports(mod) END; + mod.file.Close; mod.file := NIL + END; + mod := mod.next + END; + (* dll links *) + mod := modList; ImpHSize := ImpSize; + WHILE mod # NIL DO + IF mod.dll THEN + exp := mod.exp; + WHILE exp # NIL DO + WriteCh(0FFX); WriteCh(25X); Write4(ImageBase + ImpRva + ImpSize); (* JMP indirect *) + Reloc(CodeBase + CodeSize + exp.adr + 2); + INC(ImpSize, 4); INC(numImp); exp := exp.next + END; + INC(ImpSize, 4); INC(numImp) (* sentinel *) + END; + mod := mod.next + END + END WriteCode; + + PROCEDURE WriteConst; + VAR mod, last: Module; x: INTEGER; + BEGIN + mod := modList; last := NIL; + WHILE mod # NIL DO + IF ~mod.dll THEN + IF last # NIL THEN + Put(mod, mod.ms, ConBase + last.ma + last.ms); (* mod list *) + Reloc(ConBase + mod.ma + mod.ms); + END; + Get(mod, mod.ms + modOpts, x); + IF isStatic THEN INC(x, 10000H) END; (* set init bit (16) *) + IF isDll THEN INC(x, 1000000H) END; (* set dll bit (24) *) + Put(mod, mod.ms + modOpts, x); + Ro.WriteBytes(mod.data^, 0, mod.ms + mod.ds); + last := mod + END; + mod := mod.next + END + END WriteConst; + + PROCEDURE WriteResDir (n, i: INTEGER); + BEGIN + Write4(0); (* flags *) + Write4(timeStamp); + Write4(0); (* version *) + Write2(n); (* name entries *) + Write2(i); (* id entries *) + END WriteResDir; + + PROCEDURE WriteResDirEntry (id, adr: INTEGER; dir: BOOLEAN); + BEGIN + IF id = 0 THEN id := resHSize + 80000000H END; (* name Rva *) + Write4(id); + IF dir THEN Write4(adr + 80000000H) ELSE Write4(adr) END + END WriteResDirEntry; + + PROCEDURE WriteMenu (res: Resource); + VAR f, i: INTEGER; + BEGIN + WHILE res # NIL DO + IF res.next = NIL THEN f := 80H ELSE f := 0 END; + IF 29 IN res.opts THEN INC(f, 1) END; (* = grayed *) + IF 13 IN res.opts THEN INC(f, 2) END; (* - inctive *) + IF 3 IN res.opts THEN INC(f, 4) END; (* # bitmap *) + IF 10 IN res.opts THEN INC(f, 8) END; (* * checked *) + IF 1 IN res.opts THEN INC(f, 20H) END; (* ! menubarbreak *) + IF 15 IN res.opts THEN INC(f, 40H) END; (* / menubreak *) + IF 31 IN res.opts THEN INC(f, 100H) END; (* ? ownerdraw *) + IF res.local # NIL THEN Write2(f + 10H) ELSE Write2(f); Write2(res.id) END; + i := 0; WHILE res.name[i] # 0X DO Write2(ORD(res.name[i])); INC(i) END; + Write2(0); + WriteMenu(res.local); + res := res.next + END + END WriteMenu; + + PROCEDURE WriteResource; + VAR r, s: Resource; i, t, a, x, n, nlen, nsize: INTEGER; + BEGIN + IF numId[0] > 0 THEN WriteResDir(1, numType - 1); nlen := LEN(rsrcName$); nsize := (nlen + 1) * 2; + ELSE WriteResDir(0, numType) + END; + a := 16 + 8 * numType; t := 0; + WHILE t < LEN(numId) DO + IF numId[t] > 0 THEN WriteResDirEntry(t, a, TRUE); INC(a, 16 + 8 * numId[t]) END; + INC(t) + END; + r := resList; t := -1; + WHILE r # NIL DO + IF t # r.typ THEN t := r.typ; WriteResDir(0, numId[t]) END; + WriteResDirEntry(r.id, a, TRUE); INC(a, 16); i := r.id; + WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO INC(a, 8); r := r.next END + END; + r := resList; + WHILE r # NIL DO + n := 0; s := r; + WHILE (s # NIL) & (s.typ = r.typ) & (s.id = r.id) DO INC(n); s := s.next END; + WriteResDir(0, n); + WHILE r # s DO WriteResDirEntry(r.lid, a, FALSE); INC(a, 16); r := r.next END + END; + ASSERT(a = resHSize); + IF numId[0] > 0 THEN INC(a, nsize) END; (* TYPELIB string *) + r := resList; + WHILE r # NIL DO + Write4(a + RsrcRva); INC(a, (r.size + 3) DIV 4 * 4); + Write4(r.size); + Write4(0); Write4(0); + r := r.next + END; + ASSERT(a = RsrcSize); + IF numId[0] > 0 THEN + Write2(nlen); i := 0; + WHILE rsrcName[i] # 0X DO Write2(ORD(rsrcName[i])); INC(i) END + END; + r := resList; + WHILE r # NIL DO + IF r.typ = 4 THEN (* menu *) + Write2(0); Write2(0); + WriteMenu(r.local); + WHILE Ro.Pos() MOD 4 # 0 DO WriteCh(0X) END + ELSIF r.typ = 9 THEN (* accelerator *) + s := r.local; + WHILE s # NIL DO + i := 0; a := 0; + IF 10 IN s.opts THEN INC(a, 4) END; (* * shift *) + IF 16 IN s.opts THEN INC(a, 8) END; (* ^ ctrl *) + IF 0 IN s.opts THEN INC(a, 16) END; (* @ alt *) + IF 13 IN s.opts THEN INC(a, 2) END; (* - noinv *) + IF s.next = NIL THEN INC(a, 80H) END; + IF (s.name[0] = "v") & (s.name[1] # 0X) THEN + s.name[0] := " "; Strings.StringToInt(s.name, x, n); INC(a, 1) + ELSE x := ORD(s.name[0]) + END; + Write2(a); Write2(x); Write2(s.id); Write2(0); s := s.next + END + ELSE + r.file := ThisResFile(r.name); + IF r.file # NIL THEN + R := r.file.NewReader(R); R.SetPos(r.pos); i := 0; + IF r.typ = 12 THEN (* cursor group *) + Read4(x); Write4(x); Read2(n); Write2(n); + WHILE i < n DO + Read4(x); Write2(x MOD 256); Write2(x DIV 256 MOD 256 * 2); + Write2(1); Write2(1); Read4(x); (* ??? *) + Read4(x); Write4(x + 4); Read4(x); Write2(r.id * 10 + i); INC(i) + END; + IF ~ODD(n) THEN Write2(0) END + ELSIF r.typ = 14 THEN (* icon group *) + Read4(x); Write4(x); Read2(n); Write2(n); + WHILE i < n DO + Read2(x); Write2(x); Read2(x); + IF (13 IN r.opts) & (x = 16) THEN x := 4 END; + Write2(x); + a := x MOD 256; Read4(x); Write2(1); + IF a <= 2 THEN Write2(1) + ELSIF a <= 4 THEN Write2(2) + ELSIF a <= 16 THEN Write2(4) + ELSE Write2(8) + END; + Read4(x); + IF (13 IN r.opts) & (x = 744) THEN x := 440 END; + IF (13 IN r.opts) & (x = 296) THEN x := 184 END; + Write4(x); Read4(x); Write2(r.id * 10 + i); INC(i) + END; + IF ~ODD(n) THEN Write2(0) END + ELSE + IF r.typ = 1 THEN Write2(r.x); Write2(r.y); i := 4 END; (* cursor hot spot *) + WHILE i < r.size DO Read4(x); Write4(x); INC(i, 4) END + END; + r.file.Close; r.file := NIL + END + END; + r := r.next + END + END WriteResource; + + PROCEDURE Insert(VAR name: ARRAY OF SHORTCHAR; VAR idx: INTEGER; hint: INTEGER); + VAR i: INTEGER; + BEGIN + IF hint >= 0 THEN + ntab[idx] := SHORT(CHR(hint)); INC(idx); + ntab[idx] := SHORT(CHR(hint DIV 256)); INC(idx); + END; + i := 0; + WHILE name[i] # 0X DO ntab[idx] := name[i]; INC(idx); INC(i) END; + IF (hint = -1) & ((ntab[idx-4] # ".") OR (CAP(ntab[idx-3]) # "D") OR (CAP(ntab[idx-2]) # "L") OR (CAP(ntab[idx-1]) # "L")) THEN + ntab[idx] := "."; INC(idx); + ntab[idx] := "d"; INC(idx); + ntab[idx] := "l"; INC(idx); + ntab[idx] := "l"; INC(idx); + END; + ntab[idx] := 0X; INC(idx); + IF ODD(idx) THEN ntab[idx] := 0X; INC(idx) END + END Insert; + + PROCEDURE WriteImport; + VAR i, lt, at, nt, ai, ni: INTEGER; mod: Module; exp: Export; ss: ARRAY 256 OF SHORTCHAR; + BEGIN + IF numImp > 0 THEN NEW(atab, numImp) END; + IF numExp > numImp THEN i := numExp ELSE i := numImp END; + IF i > 0 THEN NEW(ntab, 40 * i) END; + at := ImpRva + ImpHSize; ai := 0; ni := 0; + lt := ImpRva + ImpSize; nt := lt + ImpSize - ImpHSize; + mod := modList; + WHILE mod # NIL DO + IF mod.dll THEN + Write4(lt); (* lookup table rva *) + Write4(0); (* time/data (always 0) *) + Write4(0); (* version (always 0) *) + Write4(nt + ni); (* name rva *) + ss := SHORT(mod.name$); Insert(ss, ni, -1); + Write4(at); (* addr table rva *) + exp := mod.exp; + WHILE exp # NIL DO + atab[ai] := nt + ni; (* hint/name rva *) + Insert(exp.name, ni, 0); + INC(lt, 4); INC(at, 4); INC(ai); exp := exp.next + END; + atab[ai] := 0; INC(lt, 4); INC(at, 4); INC(ai) + END; + mod := mod.next + END; + Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); + i := 0; + WHILE i < ai DO Write4(atab[i]); INC(i) END; (* address table *) + i := 0; + WHILE i < ai DO Write4(atab[i]); INC(i) END; (* lookup table *) + i := 0; + WHILE i < ni DO WriteCh(ntab[i]); INC(i) END; + ASSERT(ai * 4 = ImpSize - ImpHSize); + INC(ImpSize, ai * 4 + ni); + ExpRva := ImpRva + (ImpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + RelocRva := ExpRva; + END WriteImport; + + PROCEDURE WriteExport (VAR name: ARRAY OF CHAR); + VAR i, ni: INTEGER; e: Export; ss: ARRAY 256 OF SHORTCHAR; + BEGIN + Write4(0); (* flags *) + Write4(timeStamp); (* time stamp *) + Write4(0); (* version *) + Write4(ExpRva + 40 + 10 * numExp); (* name rva *) + Write4(1); (* ordinal base *) + Write4(numExp); (* # entries *) + Write4(numExp); (* # name ptrs *) + Write4(ExpRva + 40); (* address table rva *) + Write4(ExpRva + 40 + 4 * numExp); (* name ptr table rva *) + Write4(ExpRva + 40 + 8 * numExp); (* ordinal table rva *) + ExpSize := 40 + 10 * numExp; + (* adress table *) + e := firstExp; + WHILE e # NIL DO Write4(e.adr); e := e.next END; + (* name ptr table *) + ni := 0; e := firstExp; + ss := SHORT(name$); Insert(ss, ni, -2); + WHILE e # NIL DO + Write4(ExpRva + ExpSize + ni); Insert(e.name, ni, -2); e := e.next + END; + (* ordinal table *) + i := 0; + WHILE i < numExp DO Write2(i); INC(i) END; + (* name table *) + i := 0; + WHILE i < ni DO WriteCh(ntab[i]); INC(i) END; + ExpSize := (ExpSize + ni + 15) DIV 16 * 16; + RelocRva := ExpRva + (ExpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + END WriteExport; + + PROCEDURE Sort (l, r: INTEGER); + VAR i, j, x, t: INTEGER; + BEGIN + i := l; j := r; x := fixups[(l + r) DIV 2]; + REPEAT + WHILE fixups[i] < x DO INC(i) END; + WHILE fixups[j] > x DO DEC(j) END; + IF i <= j THEN t := fixups[i]; fixups[i] := fixups[j]; fixups[j] := t; INC(i); DEC(j) END + UNTIL i > j; + IF l < j THEN Sort(l, j) END; + IF i < r THEN Sort(i, r) END + END Sort; + + PROCEDURE WriteReloc; + VAR i, j, h, a, p: INTEGER; + BEGIN + Sort(0, noffixup - 1); i := 0; + WHILE i < noffixup DO + p := fixups[i] DIV 4096 * 4096; j := i; a := p + 4096; + WHILE (j < noffixup) & (fixups[j] < a) DO INC(j) END; + Write4(p - ImageBase); (* page rva *) + h := 8 + 2 * (j - i); + Write4(h + h MOD 4); (* block size *) + INC(RelocSize, h); + WHILE i < j DO Write2(fixups[i] - p + 3 * 4096); INC(i) END; (* long fix *) + IF h MOD 4 # 0 THEN Write2(0); INC(RelocSize, 2) END + END; + Write4(0); Write4(0); INC(RelocSize, 8); + ImagesSize := RelocRva + (RelocSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; + END WriteReloc; + + PROCEDURE Align(VAR pos: INTEGER); + BEGIN + WHILE Ro.Pos() MOD FileAlign # 0 DO WriteCh(0X) END; + pos := Ro.Pos() + END Align; + + PROCEDURE WriteOut (VAR name: Files.Name); + VAR res, codepos, conpos, rsrcpos, imppos, exppos, relpos, relend, end: INTEGER; + BEGIN + IF ~error THEN Align(codepos); WriteCode END; + IF ~error THEN Align(conpos); WriteConst END; + IF ~error THEN Align(rsrcpos); WriteResource END; + IF ~error THEN Align(imppos); WriteImport END; + IF ~error & isDll THEN Align(exppos); WriteExport(name) END; + IF ~error THEN Align(relpos); WriteReloc END; + relend := Ro.Pos() - 8; Align(end); + + IF ~error THEN + Ro.SetPos(entryPos); Write4(CodeRva); + Ro.SetPos(isPos); Write4(ImagesSize); + IF isDll THEN + Ro.SetPos(hexpPos); Write4(ExpRva); Write4(ExpSize); + END; + Ro.SetPos(himpPos); Write4(ImpRva); Write4(ImpHSize); + Ro.SetPos(hrsrcPos); Write4(RsrcRva); Write4(RsrcSize); + Ro.SetPos(fixPos); Write4(RelocRva); Write4(relend - relpos); + + Ro.SetPos(codePos); Write4(CodeRva); Write4(conpos - HeaderSize); Write4(HeaderSize); + Ro.SetPos(dataPos); Write4(DataRva); Write4((DataSize + (FileAlign-1)) DIV FileAlign * FileAlign); + Ro.SetPos(conPos); Write4(ConRva); Write4(rsrcpos - conpos); Write4(conpos); + Ro.SetPos(rsrcPos); Write4(RsrcRva); Write4(imppos - rsrcpos); Write4(rsrcpos); + IF isDll THEN + Ro.SetPos(impPos); Write4(ImpRva); Write4(exppos - imppos); Write4(imppos); + Ro.SetPos(expPos); Write4(ExpRva); Write4(relpos - exppos); Write4(exppos) + ELSE + Ro.SetPos(impPos); Write4(ImpRva); Write4(relpos - imppos); Write4(imppos); + END; + Ro.SetPos(relPos); Write4(RelocRva); Write4(end - relpos); Write4(relpos); + IF isStatic THEN + Ro.SetPos(termPos); WriteTermCode(modList, 0) + ELSIF isDll THEN + Ro.SetPos(termPos); WriteTermCode(main, 0) + END + END; + + IF ~error THEN + Out.Register(name, "exe", Files.ask, res); + IF res # 0 THEN error := TRUE END + END + END WriteOut; + + (* A. V. Shiryaev: Scanner *) + + PROCEDURE (VAR S: Scanner) SetPos (x: INTEGER), NEW; + BEGIN + S.rider.i := x + END SetPos; + + PROCEDURE (VAR S: Scanner) ConnectTo (IN src: ARRAY OF CHAR), NEW; + BEGIN + NEW(S.rider.s, LEN(src$) + 1); + S.rider.s^ := src$; + S.rider.i := 0; + S.start := 0; + S.type := TMEOT + END ConnectTo; + + PROCEDURE (VAR R: ScanRider) ReadPrevChar (VAR ch: CHAR), NEW; + BEGIN + ch := R.s[R.i] + END ReadPrevChar; + + PROCEDURE (VAR R: ScanRider) ReadChar (VAR ch: CHAR), NEW; + BEGIN + ch := R.s[R.i]; + INC(R.i) + END ReadChar; + + PROCEDURE (VAR R: ScanRider) Pos (): INTEGER, NEW; + BEGIN + RETURN R.i + END Pos; + + PROCEDURE (VAR S: Scanner) Scan, NEW; + VAR j, res: INTEGER; + + PROCEDURE IsLetter (c: CHAR): BOOLEAN; + BEGIN + RETURN ((c >= 'A') & (c <= 'Z')) OR ((c >= 'a') & (c <= 'z')) OR (c = '_') + END IsLetter; + + PROCEDURE IsDigit (c: CHAR): BOOLEAN; + BEGIN + RETURN (c >= '0') & (c <= '9') + END IsDigit; + + BEGIN + WHILE (S.rider.i < LEN(S.rider.s$)) & (S.rider.s[S.rider.i] = ' ') DO + INC(S.rider.i) + END; + IF S.rider.i < LEN(S.rider.s$) THEN + S.start := S.rider.i; + IF IsDigit(S.rider.s[S.rider.i]) THEN + j := 0; + WHILE (S.rider.i < LEN(S.rider.s$)) & IsDigit(S.rider.s[S.rider.i]) DO + S.string[j] := S.rider.s[S.rider.i]; + INC(j); + INC(S.rider.i) + END; + S.string[j] := 0X; + Strings.StringToInt(S.string, S.int, res); + IF res # 0 THEN S.type := TMEOT + ELSE S.type := TMInt + END + ELSIF IsLetter(S.rider.s[S.rider.i]) THEN + S.type := TMString; + j := 0; + WHILE (S.rider.i < LEN(S.rider.s$)) & (IsLetter(S.rider.s[S.rider.i]) OR IsDigit(S.rider.s[S.rider.i])) DO + S.string[j] := S.rider.s[S.rider.i]; + INC(j); + INC(S.rider.i) + END; + S.string[j] := 0X + ELSE + S.type := TMChar; + S.char := S.rider.s[S.rider.i]; + INC(S.rider.i) + END + ELSE + S.type := TMEOT + END + END Scan; + + PROCEDURE ScanRes (VAR S: Scanner; end: INTEGER; VAR list: Resource); + VAR res, tail: Resource; n: INTEGER; + BEGIN + tail := NIL; + WHILE (S.start < end) & (S.type = TMInt) DO + NEW(res); res.id := S.int; S.Scan; + IF (S.type = TMChar) & (S.char = "[") THEN + S.Scan; + IF S.type = TMInt THEN res.lid := S.int; S.Scan END; + IF (S.type = TMChar) & (S.char = "]") THEN S.Scan + ELSE WriteSString("missing ']'"); error := TRUE + END + END; + WHILE S.type = TMChar DO + IF S.char = "@" THEN n := 0 + ELSIF S.char = "^" THEN n := 16 + ELSIF S.char = "~" THEN n := 17 + ELSIF S.char <= "?" THEN n := ORD(S.char) - ORD(" ") + END; + INCL(res.opts, n); S.Scan + END; + IF S.type = TMString THEN + res.name := S.string$; S.Scan; + IF (S.type = TMChar) & (S.char = ".") THEN S.Scan; + IF S.type = TMString THEN + IF (S.string = "tlb") OR (S.string = "TLB") THEN res.typ := -1 END; + Kernel.MakeFileName(res.name, S.string); S.Scan + END + END; + IF (S.type = TMChar) & (S.char = "(") THEN S.Scan; + ScanRes(S, end, res.local); + IF (S.type = TMChar) & (S.char = ")") THEN S.Scan + ELSE WriteSString("missing ')'"); error := TRUE + END + END; + IF tail = NIL THEN list := res ELSE tail.next := res END; + tail := res + ELSE + WriteSString("wrong resource name"); error := TRUE + END + END; + END ScanRes; + + PROCEDURE LinkIt (IN txt: ARRAY OF CHAR); + VAR S: Scanner; name: Files.Name; mod: Module; end: INTEGER; + BEGIN + comLine := FALSE; + modList := NIL; kernel := NIL; main := NIL; + last := NIL; impg := NIL; impd := NIL; resList := NIL; + firstExp := NIL; lastExp := NIL; + NEW(fixups, FixLen); + +(* + Dialog.ShowStatus("linking"); +*) + Console.WriteStr("linking"); Console.WriteLn; + +(* + timeStamp := TimeStamp(); +*) + timeStamp := 0; + + error := FALSE; modList := NIL; resList := NIL; + +(* + IF DevCommanders.par = NIL THEN RETURN END; + S.ConnectTo(DevCommanders.par.text); + S.SetPos(DevCommanders.par.beg); + end := DevCommanders.par.end; + DevCommanders.par := NIL; + W.ConnectTo(Log.buf); +*) + + S.ConnectTo(txt); + S.SetPos(0); + end := LEN(txt$); + + S.Scan; + IF S.type = TMString THEN + IF S.string = "dos" THEN comLine := TRUE; S.Scan END; + name := S.string$; S.Scan; + IF (S.type = TMChar) & (S.char = ".") THEN S.Scan; + IF S.type = TMString THEN + Kernel.MakeFileName(name, S.string); S.Scan + END + ELSE Kernel.MakeFileName(name, "EXE"); + END; + IF (S.type = TMChar) & (S.char = ":") THEN S.Scan; + IF (S.type = TMChar) & (S.char = "=") THEN S.Scan; + WHILE (S.start < end) & (S.type = TMString) DO + NEW(mod); mod.name := S.string$; + mod.next := modList; modList := mod; + S.Scan; + WHILE (S.start < end) & (S.type = TMChar) & + ((S.char = "*") OR (S.char = "+") OR (S.char = "$") OR (S.char = "#")) DO + IF S.char = "*" THEN mod.dll := TRUE + ELSIF S.char = "+" THEN kernel := mod + ELSIF S.char = "$" THEN main := mod + ELSE mod.intf := TRUE; + IF ~isDll THEN + WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll."); + WriteLn; FlushW; error := TRUE + END + END; + S.Scan + END + END; + ScanRes(S, end, resList); + ReadHeaders; + PrepResources; + IF ~error THEN WriteHeader(name) END; + IF ~error THEN WriteOut(name) END; + IF ~error THEN + WriteString(name); WriteString(" written "); + WriteInt(Out.Length()); WriteString(" "); WriteInt(CodeSize) + END + ELSE WriteString(" := missing") + END + ELSE WriteString(" := missing") + END; + WriteLn; FlushW + END; +(* + IF error THEN Dialog.ShowStatus("failed") ELSE Dialog.ShowStatus("ok") END; + W.ConnectTo(NIL); S.ConnectTo(NIL); +*) + IF error THEN Console.WriteStr("failed") ELSE Console.WriteStr("ok") END; Console.WriteLn; + S.ConnectTo(""); + + modList := NIL; kernel := NIL; main := NIL; firstExp := NIL; lastExp := NIL; + last := NIL; impg := NIL; impd := NIL; resList := NIL; code := NIL; atab := NIL; ntab := NIL; + fixups := NIL + END LinkIt; + + PROCEDURE Link* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := FALSE; isStatic := FALSE; + LinkIt(txt) + END Link; + + PROCEDURE LinkExe* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := FALSE; isStatic := TRUE; + LinkIt(txt) + END LinkExe; + + PROCEDURE LinkDll* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := TRUE; isStatic := TRUE; + LinkIt(txt) + END LinkDll; + + PROCEDURE LinkDynDll* (IN txt: ARRAY OF CHAR); + BEGIN + isDll := TRUE; isStatic := FALSE; + LinkIt(txt) + END LinkDynDll; + +(* + PROCEDURE Show*; + VAR S: TextMappers.Scanner; name: Name; mod: Module; t: TextModels.Model; + BEGIN + t := TextViews.FocusText(); IF t = NIL THEN RETURN END; + W.ConnectTo(Log.buf); S.ConnectTo(t); S.Scan; + IF S.type = TextMappers.string THEN + mod := modList; + WHILE (mod # NIL) & (mod.name # S.string) DO mod := mod.next END; + IF mod # NIL THEN + W.WriteString(S.string); + W.WriteString(" ca = "); + W.WriteIntForm(CodeBase + mod.ca, TextMappers.hexadecimal, 8, "0", TRUE); + W.WriteLn; Log.text.Append(Log.buf) + END + END; + W.ConnectTo(NIL); S.ConnectTo(NIL) + END Show; +*) + +BEGIN + newRec := "NewRec"; newArr := "NewArr" +END Dev0Linker. + + +(!)DevLinker.Link Usekrnl.exe := TestKernel$+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')" + +(!)DevLinker.LinkDynDll MYDLL.dll := TestKernel+ MYDLL$# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')" + +(!)DevLinker.LinkExe Usekrnl.exe := TestKernel+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')" + +(!)DevLinker.LinkDll MYDLL.dll := TestKernel+ MYDLL# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')" + + +MODULE TestKernel; + IMPORT KERNEL32; + + PROCEDURE Beep*; + BEGIN + KERNEL32.Beep(500, 200) + END Beep; + +BEGIN +CLOSE + KERNEL32.ExitProcess(0) +END TestKernel. + +MODULE Usekrnl; +(* empty windows application using BlackBox Kernel *) +(* Ominc (!) *) + + IMPORT KERNEL32, USER32, GDI32, S := SYSTEM, Kernel := TestKernel; + + VAR Instance, MainWnd: USER32.Handle; + + PROCEDURE WndHandler (wnd, message, wParam, lParam: INTEGER): INTEGER; + VAR res: INTEGER; ps: USER32.PaintStruct; dc: GDI32.Handle; + BEGIN + IF message = USER32.WMDestroy THEN + USER32.PostQuitMessage(0) + ELSIF message = USER32.WMPaint THEN + dc := USER32.BeginPaint(wnd, ps); + res := GDI32.TextOutA(dc, 50, 50, "Hello World", 11); + res := USER32.EndPaint(wnd, ps) + ELSIF message = USER32.WMChar THEN + Kernel.Beep + ELSE + RETURN USER32.DefWindowProcA(wnd, message, wParam, lParam) + END; + RETURN 0 + END WndHandler; + + PROCEDURE OpenWindow; + VAR class: USER32.WndClass; res: INTEGER; + BEGIN + class.cursor := USER32.LoadCursorA(0, USER32.MakeIntRsrc(USER32.IDCArrow)); + class.icon := USER32.LoadIconA(Instance, USER32.MakeIntRsrc(1)); + class.menuName := NIL; + class.className := "Simple"; + class.backgnd := GDI32.GetStockObject(GDI32.WhiteBrush); + class.style := {0, 1, 5, 7}; + class.instance := Instance; + class.wndProc := WndHandler; + class.clsExtra := 0; + class.wndExtra := 0; + USER32.RegisterClassA(class); + MainWnd := USER32.CreateWindowExA({}, "Simple", "Empty Windows Application", + {16..19, 22, 23, 25}, + USER32.CWUseDefault, USER32.CWUseDefault, + USER32.CWUseDefault, USER32.CWUseDefault, + 0, 0, Instance, 0); + res := USER32.ShowWindow(MainWnd, 10); + res := USER32.UpdateWindow(MainWnd); + END OpenWindow; + + PROCEDURE MainLoop; + VAR msg: USER32.Message; res: INTEGER; + BEGIN + WHILE USER32.GetMessageA(msg, 0, 0, 0) # 0 DO + res := USER32.TranslateMessage(msg); + res := USER32.DispatchMessageA(msg); + END; +(* + KERNEL32.ExitProcess(msg.wParam) +*) + END MainLoop; + +BEGIN + Instance := KERNEL32.GetModuleHandleA(NIL); + OpenWindow; + MainLoop +CLOSE + Kernel.Beep +END Usekrnl. + + +MODULE MYDLL; +(* sample module to be linked into a dll *) +(* Ominc (!) *) + + IMPORT SYSTEM, KERNEL32; + + VAR expVar*: INTEGER; + + PROCEDURE GCD* (a, b: INTEGER): INTEGER; + BEGIN + WHILE a # b DO + IF a < b THEN b := b - a ELSE a := a - b END + END; + expVar := a; + RETURN a + END GCD; + + PROCEDURE Beep*; + BEGIN + KERNEL32.Beep(500, 200) + END Beep; + +CLOSE + Beep +END MYDLL. + + + +Resource = Id [ "[" Language "]" ] Options name [ "." ext ] [ "(" { Resource } ")" ] +Id = number +Language = number +Options = { "@" | "!" .. "?" | "^" | "~" } + +names + +MENU + 1 MENU (0 File (11 New 12 Open 13 Save 0 "" 14 Exit) 0 Edit (21 Cut 22 Copy 23 Paste)) + = grayed + - inctive + # bitmap + * checked + ! menuBarBreak + / menuBreak + ? ownerDraw + +ACCELERATOR + 1 ACCELERATOR (11 ^N 12 ^O 13 ^S 21 ^X 22 ^C 23 ^V) + * shift + ^ ctrl + @ alt + - noInvert + +filename.ico + +filename.cur + +filname.bmp + +filename.res + +filename.tlb diff --git a/Trurl-based/Dev0/Views.txt b/Trurl-based/Dev0/Views.txt new file mode 100644 index 0000000..9f4e270 --- /dev/null +++ b/Trurl-based/Dev0/Views.txt @@ -0,0 +1,14 @@ +MODULE Views; + + (* TO COMPILE StdInterpreter *) + + PROCEDURE Available* (): INTEGER; + BEGIN + RETURN 0 + END Available; + + PROCEDURE ClearQueue*; + BEGIN + END ClearQueue; + +END Views. diff --git a/Trurl-based/Docu/BB-Chars.odc b/Trurl-based/Docu/BB-Chars.odc new file mode 100644 index 0000000..4b468c3 Binary files /dev/null and b/Trurl-based/Docu/BB-Chars.odc differ diff --git a/Trurl-based/Docu/BB-Docu.odc b/Trurl-based/Docu/BB-Docu.odc new file mode 100644 index 0000000..f853285 Binary files /dev/null and b/Trurl-based/Docu/BB-Docu.odc differ diff --git a/Trurl-based/Docu/BB-License.odc b/Trurl-based/Docu/BB-License.odc new file mode 100644 index 0000000..f5847d5 Binary files /dev/null and b/Trurl-based/Docu/BB-License.odc differ diff --git a/Trurl-based/Docu/BB-Licensing-Policy.odc b/Trurl-based/Docu/BB-Licensing-Policy.odc new file mode 100644 index 0000000..f1d0966 Binary files /dev/null and b/Trurl-based/Docu/BB-Licensing-Policy.odc differ diff --git a/Trurl-based/Docu/BB-Open-Source-License.odc b/Trurl-based/Docu/BB-Open-Source-License.odc new file mode 100644 index 0000000..f5847d5 Binary files /dev/null and b/Trurl-based/Docu/BB-Open-Source-License.odc differ diff --git a/Trurl-based/Docu/BB-Road.odc b/Trurl-based/Docu/BB-Road.odc new file mode 100644 index 0000000..913febf Binary files /dev/null and b/Trurl-based/Docu/BB-Road.odc differ diff --git a/Trurl-based/Docu/BB-Rules.odc b/Trurl-based/Docu/BB-Rules.odc new file mode 100644 index 0000000..613aae0 Binary files /dev/null and b/Trurl-based/Docu/BB-Rules.odc differ diff --git a/Trurl-based/Docu/CP-Lang.odc b/Trurl-based/Docu/CP-Lang.odc new file mode 100644 index 0000000..029e7a6 Binary files /dev/null and b/Trurl-based/Docu/CP-Lang.odc differ diff --git a/Trurl-based/Docu/CP-New.odc b/Trurl-based/Docu/CP-New.odc new file mode 100644 index 0000000..a122c35 Binary files /dev/null and b/Trurl-based/Docu/CP-New.odc differ diff --git a/Trurl-based/Docu/Contributors.odc b/Trurl-based/Docu/Contributors.odc new file mode 100644 index 0000000..4461178 Binary files /dev/null and b/Trurl-based/Docu/Contributors.odc differ diff --git a/Trurl-based/Docu/Help.odc b/Trurl-based/Docu/Help.odc new file mode 100644 index 0000000..97b3a6c Binary files /dev/null and b/Trurl-based/Docu/Help.odc differ diff --git a/Trurl-based/Docu/OpenBUGS-License.odc b/Trurl-based/Docu/OpenBUGS-License.odc new file mode 100644 index 0000000..56b09d3 Binary files /dev/null and b/Trurl-based/Docu/OpenBUGS-License.odc differ diff --git a/Trurl-based/Docu/Tut-1.odc b/Trurl-based/Docu/Tut-1.odc new file mode 100644 index 0000000..4434fcc Binary files /dev/null and b/Trurl-based/Docu/Tut-1.odc differ diff --git a/Trurl-based/Docu/Tut-2.odc b/Trurl-based/Docu/Tut-2.odc new file mode 100644 index 0000000..92bc346 Binary files /dev/null and b/Trurl-based/Docu/Tut-2.odc differ diff --git a/Trurl-based/Docu/Tut-3.odc b/Trurl-based/Docu/Tut-3.odc new file mode 100644 index 0000000..9836a54 Binary files /dev/null and b/Trurl-based/Docu/Tut-3.odc differ diff --git a/Trurl-based/Docu/Tut-4.odc b/Trurl-based/Docu/Tut-4.odc new file mode 100644 index 0000000..84ac505 Binary files /dev/null and b/Trurl-based/Docu/Tut-4.odc differ diff --git a/Trurl-based/Docu/Tut-5.odc b/Trurl-based/Docu/Tut-5.odc new file mode 100644 index 0000000..9e5f04a Binary files /dev/null and b/Trurl-based/Docu/Tut-5.odc differ diff --git a/Trurl-based/Docu/Tut-6.odc b/Trurl-based/Docu/Tut-6.odc new file mode 100644 index 0000000..2561fe0 Binary files /dev/null and b/Trurl-based/Docu/Tut-6.odc differ diff --git a/Trurl-based/Docu/Tut-A.odc b/Trurl-based/Docu/Tut-A.odc new file mode 100644 index 0000000..1042c09 Binary files /dev/null and b/Trurl-based/Docu/Tut-A.odc differ diff --git a/Trurl-based/Docu/Tut-B.odc b/Trurl-based/Docu/Tut-B.odc new file mode 100644 index 0000000..6fdf557 Binary files /dev/null and b/Trurl-based/Docu/Tut-B.odc differ diff --git a/Trurl-based/Docu/Tut-TOC.odc b/Trurl-based/Docu/Tut-TOC.odc new file mode 100644 index 0000000..f95f49b Binary files /dev/null and b/Trurl-based/Docu/Tut-TOC.odc differ diff --git a/Trurl-based/Docu/Tut-Tot.odc b/Trurl-based/Docu/Tut-Tot.odc new file mode 100644 index 0000000..be3c8e3 Binary files /dev/null and b/Trurl-based/Docu/Tut-Tot.odc differ diff --git a/Trurl-based/Obx/Mod/Hello0.odc b/Trurl-based/Obx/Mod/Hello0.odc new file mode 100644 index 0000000..ece1877 Binary files /dev/null and b/Trurl-based/Obx/Mod/Hello0.odc differ diff --git a/Trurl-based/Obx/Mod/Pi.odc b/Trurl-based/Obx/Mod/Pi.odc new file mode 100644 index 0000000..3e6bab9 Binary files /dev/null and b/Trurl-based/Obx/Mod/Pi.odc differ diff --git a/Trurl-based/Obx/Mod/Random.odc b/Trurl-based/Obx/Mod/Random.odc new file mode 100644 index 0000000..436999e Binary files /dev/null and b/Trurl-based/Obx/Mod/Random.odc differ diff --git a/Trurl-based/Obx/Mod/Trap.odc b/Trurl-based/Obx/Mod/Trap.odc new file mode 100644 index 0000000..26997b1 Binary files /dev/null and b/Trurl-based/Obx/Mod/Trap.odc differ diff --git a/Trurl-based/Sql/Database/Companies b/Trurl-based/Sql/Database/Companies new file mode 100644 index 0000000..166dce9 --- /dev/null +++ b/Trurl-based/Sql/Database/Companies @@ -0,0 +1,22 @@ +"id","name","ceo","employees" +11,"Test","Bill",234 +12,"Test","Bill",234 +13,"Test company AG","John",45 +14,"Test","Bill",234 +15,"Test company AG","John",45 +16,"Test Services GmbH","Jim",23000 +17,"Test Commands & Co.","Mary",523 +18,"Test","Bill",234 +19,"Test company AG","John",45 +20,"Test Services GmbH","Jim",23000 +21,"Test Commands & Co.","Mary",523 +1,"Test","Bill",234 +2,"Test company AG","John",45 +3,"Test Services GmbH","Jim",23000 +4,"Test Commands & Co.","Mary",523 +5,"Test Views KG","Frank",17 +6,"Test Genossenschaft","Hans",2109 +7,"Test Mentoring, Inc.","Marlis",128 +8,"Test Training Plc.","Paul",4 +9,"Test Trainers SA","Jean",87 +10,"Test Wrappers AB","Gordon",912 diff --git a/Trurl-based/Sql/Database/Ownership b/Trurl-based/Sql/Database/Ownership new file mode 100644 index 0000000..4880aed --- /dev/null +++ b/Trurl-based/Sql/Database/Ownership @@ -0,0 +1,19 @@ +"owner","owned","percent" +12,13,100 +14,15,50 +15,17,100 +16,15,50 +15,17,100 +18,19,20 +18,20,30 +18,21,50 +1,2,100 +1,3,100 +2,4,100 +2,5,100 +3,6,100 +3,7,100 +7,8,100 +5,9,49 +8,9,51 +9,10,100 diff --git a/Trurl-based/Sql/Database/schema.ini b/Trurl-based/Sql/Database/schema.ini new file mode 100644 index 0000000..8e6f108 --- /dev/null +++ b/Trurl-based/Sql/Database/schema.ini @@ -0,0 +1,15 @@ +[Companies] +ColNameHeader=True +CharacterSet=OEM +Format=CSVDelimited +Col1=id Integer +Col2=name Char Width 255 +Col3=ceo Char Width 255 +Col4=employees Integer +[Ownership] +ColNameHeader=True +CharacterSet=OEM +Format=CSVDelimited +Col1=owner Integer +Col2=owned Integer +Col3=percent Integer diff --git a/Trurl-based/Sql/Docu/Browser.odc b/Trurl-based/Sql/Docu/Browser.odc new file mode 100644 index 0000000..9ab8d2c Binary files /dev/null and b/Trurl-based/Sql/Docu/Browser.odc differ diff --git a/Trurl-based/Sql/Docu/Controls.odc b/Trurl-based/Sql/Docu/Controls.odc new file mode 100644 index 0000000..3cb704f Binary files /dev/null and b/Trurl-based/Sql/Docu/Controls.odc differ diff --git a/Trurl-based/Sql/Docu/Db.odc b/Trurl-based/Sql/Docu/Db.odc new file mode 100644 index 0000000..824d034 Binary files /dev/null and b/Trurl-based/Sql/Docu/Db.odc differ diff --git a/Trurl-based/Sql/Docu/Dev-Man.odc b/Trurl-based/Sql/Docu/Dev-Man.odc new file mode 100644 index 0000000..0c179c0 Binary files /dev/null and b/Trurl-based/Sql/Docu/Dev-Man.odc differ diff --git a/Trurl-based/Sql/Docu/Drivers.odc b/Trurl-based/Sql/Docu/Drivers.odc new file mode 100644 index 0000000..139ec17 Binary files /dev/null and b/Trurl-based/Sql/Docu/Drivers.odc differ diff --git a/Trurl-based/Sql/Docu/ObxDB.odc b/Trurl-based/Sql/Docu/ObxDB.odc new file mode 100644 index 0000000..c1c581e Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxDB.odc differ diff --git a/Trurl-based/Sql/Docu/ObxDriv.odc b/Trurl-based/Sql/Docu/ObxDriv.odc new file mode 100644 index 0000000..3c009d9 Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxDriv.odc differ diff --git a/Trurl-based/Sql/Docu/ObxExt.odc b/Trurl-based/Sql/Docu/ObxExt.odc new file mode 100644 index 0000000..255de91 Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxExt.odc differ diff --git a/Trurl-based/Sql/Docu/ObxGen.odc b/Trurl-based/Sql/Docu/ObxGen.odc new file mode 100644 index 0000000..64c50ee Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxGen.odc differ diff --git a/Trurl-based/Sql/Docu/ObxInit.odc b/Trurl-based/Sql/Docu/ObxInit.odc new file mode 100644 index 0000000..c9faece Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxInit.odc differ diff --git a/Trurl-based/Sql/Docu/ObxNets.odc b/Trurl-based/Sql/Docu/ObxNets.odc new file mode 100644 index 0000000..16d661f Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxNets.odc differ diff --git a/Trurl-based/Sql/Docu/ObxTab.odc b/Trurl-based/Sql/Docu/ObxTab.odc new file mode 100644 index 0000000..b8fce7a Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxTab.odc differ diff --git a/Trurl-based/Sql/Docu/ObxUI.odc b/Trurl-based/Sql/Docu/ObxUI.odc new file mode 100644 index 0000000..2d380d6 Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxUI.odc differ diff --git a/Trurl-based/Sql/Docu/ObxViews.odc b/Trurl-based/Sql/Docu/ObxViews.odc new file mode 100644 index 0000000..f8b4cea Binary files /dev/null and b/Trurl-based/Sql/Docu/ObxViews.odc differ diff --git a/Trurl-based/Sql/Docu/Odbc.odc b/Trurl-based/Sql/Docu/Odbc.odc new file mode 100644 index 0000000..c0721b9 Binary files /dev/null and b/Trurl-based/Sql/Docu/Odbc.odc differ diff --git a/Trurl-based/Sql/Docu/Odbc3.odc b/Trurl-based/Sql/Docu/Odbc3.odc new file mode 100644 index 0000000..ac6f654 Binary files /dev/null and b/Trurl-based/Sql/Docu/Odbc3.odc differ diff --git a/Trurl-based/Sql/Docu/Sys-Map.odc b/Trurl-based/Sql/Docu/Sys-Map.odc new file mode 100644 index 0000000..07e8d60 Binary files /dev/null and b/Trurl-based/Sql/Docu/Sys-Map.odc differ diff --git a/Trurl-based/Sql/Mod/Browser.odc b/Trurl-based/Sql/Mod/Browser.odc new file mode 100644 index 0000000..cf26b74 Binary files /dev/null and b/Trurl-based/Sql/Mod/Browser.odc differ diff --git a/Trurl-based/Sql/Mod/Controls.odc b/Trurl-based/Sql/Mod/Controls.odc new file mode 100644 index 0000000..6768a51 Binary files /dev/null and b/Trurl-based/Sql/Mod/Controls.odc differ diff --git a/Trurl-based/Sql/Mod/DB.odc b/Trurl-based/Sql/Mod/DB.odc new file mode 100644 index 0000000..19eca6a Binary files /dev/null and b/Trurl-based/Sql/Mod/DB.odc differ diff --git a/Trurl-based/Sql/Mod/Drivers.odc b/Trurl-based/Sql/Mod/Drivers.odc new file mode 100644 index 0000000..842602d Binary files /dev/null and b/Trurl-based/Sql/Mod/Drivers.odc differ diff --git a/Trurl-based/Sql/Mod/ObxDB.odc b/Trurl-based/Sql/Mod/ObxDB.odc new file mode 100644 index 0000000..be71eb6 Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxDB.odc differ diff --git a/Trurl-based/Sql/Mod/ObxDriv.odc b/Trurl-based/Sql/Mod/ObxDriv.odc new file mode 100644 index 0000000..5d3b3eb Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxDriv.odc differ diff --git a/Trurl-based/Sql/Mod/ObxExt.odc b/Trurl-based/Sql/Mod/ObxExt.odc new file mode 100644 index 0000000..7e9d871 Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxExt.odc differ diff --git a/Trurl-based/Sql/Mod/ObxGen.odc b/Trurl-based/Sql/Mod/ObxGen.odc new file mode 100644 index 0000000..369327e Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxGen.odc differ diff --git a/Trurl-based/Sql/Mod/ObxInit.odc b/Trurl-based/Sql/Mod/ObxInit.odc new file mode 100644 index 0000000..e894926 Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxInit.odc differ diff --git a/Trurl-based/Sql/Mod/ObxNets.odc b/Trurl-based/Sql/Mod/ObxNets.odc new file mode 100644 index 0000000..f051bef Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxNets.odc differ diff --git a/Trurl-based/Sql/Mod/ObxTab.odc b/Trurl-based/Sql/Mod/ObxTab.odc new file mode 100644 index 0000000..a5c0eb3 Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxTab.odc differ diff --git a/Trurl-based/Sql/Mod/ObxUI.odc b/Trurl-based/Sql/Mod/ObxUI.odc new file mode 100644 index 0000000..a380248 Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxUI.odc differ diff --git a/Trurl-based/Sql/Mod/ObxViews.odc b/Trurl-based/Sql/Mod/ObxViews.odc new file mode 100644 index 0000000..c2f8aaf Binary files /dev/null and b/Trurl-based/Sql/Mod/ObxViews.odc differ diff --git a/Trurl-based/Sql/Rsrc/Browser.odc b/Trurl-based/Sql/Rsrc/Browser.odc new file mode 100644 index 0000000..1d3f084 Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Browser.odc differ diff --git a/Trurl-based/Sql/Rsrc/Company.odc b/Trurl-based/Sql/Rsrc/Company.odc new file mode 100644 index 0000000..4ae9abf Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Company.odc differ diff --git a/Trurl-based/Sql/Rsrc/Debug.odc b/Trurl-based/Sql/Rsrc/Debug.odc new file mode 100644 index 0000000..70fbe72 Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Debug.odc differ diff --git a/Trurl-based/Sql/Rsrc/Menus.odc b/Trurl-based/Sql/Rsrc/Menus.odc new file mode 100644 index 0000000..211b6eb Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Menus.odc differ diff --git a/Trurl-based/Sql/Rsrc/Owner.odc b/Trurl-based/Sql/Rsrc/Owner.odc new file mode 100644 index 0000000..85504fa Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Owner.odc differ diff --git a/Trurl-based/Sql/Rsrc/Strings.odc b/Trurl-based/Sql/Rsrc/Strings.odc new file mode 100644 index 0000000..c5afe43 Binary files /dev/null and b/Trurl-based/Sql/Rsrc/Strings.odc differ diff --git a/Trurl-based/Std/Mod/Api.txt b/Trurl-based/Std/Mod/Api.txt new file mode 100644 index 0000000..d89cc42 --- /dev/null +++ b/Trurl-based/Std/Mod/Api.txt @@ -0,0 +1,229 @@ +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/Trurl-based/Std/Mod/CFrames.txt b/Trurl-based/Std/Mod/CFrames.txt new file mode 100644 index 0000000..7a157db --- /dev/null +++ b/Trurl-based/Std/Mod/CFrames.txt @@ -0,0 +1,243 @@ +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/Trurl-based/Std/Mod/Clocks.txt b/Trurl-based/Std/Mod/Clocks.txt new file mode 100644 index 0000000..f7e4917 --- /dev/null +++ b/Trurl-based/Std/Mod/Clocks.txt @@ -0,0 +1,183 @@ +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/Trurl-based/Std/Mod/Cmds.txt b/Trurl-based/Std/Mod/Cmds.txt new file mode 100644 index 0000000..76e5ae9 --- /dev/null +++ b/Trurl-based/Std/Mod/Cmds.txt @@ -0,0 +1,1016 @@ +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/Trurl-based/Std/Mod/Coder.txt b/Trurl-based/Std/Mod/Coder.txt new file mode 100644 index 0000000..2e25873 --- /dev/null +++ b/Trurl-based/Std/Mod/Coder.txt @@ -0,0 +1,682 @@ +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/Trurl-based/Std/Mod/Debug.txt b/Trurl-based/Std/Mod/Debug.txt new file mode 100644 index 0000000..8583d7d --- /dev/null +++ b/Trurl-based/Std/Mod/Debug.txt @@ -0,0 +1,621 @@ +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/Trurl-based/Std/Mod/Dialog.txt b/Trurl-based/Std/Mod/Dialog.txt new file mode 100644 index 0000000..24aecdd --- /dev/null +++ b/Trurl-based/Std/Mod/Dialog.txt @@ -0,0 +1,297 @@ +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/Trurl-based/Std/Mod/ETHConv.txt b/Trurl-based/Std/Mod/ETHConv.txt new file mode 100644 index 0000000..944e019 --- /dev/null +++ b/Trurl-based/Std/Mod/ETHConv.txt @@ -0,0 +1,223 @@ +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/Trurl-based/Std/Mod/Folds.txt b/Trurl-based/Std/Mod/Folds.txt new file mode 100644 index 0000000..87b2867 --- /dev/null +++ b/Trurl-based/Std/Mod/Folds.txt @@ -0,0 +1,779 @@ +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/Trurl-based/Std/Mod/Headers.txt b/Trurl-based/Std/Mod/Headers.txt new file mode 100644 index 0000000..c87935c --- /dev/null +++ b/Trurl-based/Std/Mod/Headers.txt @@ -0,0 +1,436 @@ +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/Trurl-based/Std/Mod/Interpreter.txt b/Trurl-based/Std/Mod/Interpreter.txt new file mode 100644 index 0000000..b619a2c --- /dev/null +++ b/Trurl-based/Std/Mod/Interpreter.txt @@ -0,0 +1,234 @@ +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/Trurl-based/Std/Mod/Links.txt b/Trurl-based/Std/Mod/Links.txt new file mode 100644 index 0000000..7bc3bbc --- /dev/null +++ b/Trurl-based/Std/Mod/Links.txt @@ -0,0 +1,893 @@ +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/Trurl-based/Std/Mod/Loader.txt b/Trurl-based/Std/Mod/Loader.txt new file mode 100644 index 0000000..f883f21 --- /dev/null +++ b/Trurl-based/Std/Mod/Loader.txt @@ -0,0 +1,336 @@ +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/Trurl-based/Std/Mod/Log.txt b/Trurl-based/Std/Mod/Log.txt new file mode 100644 index 0000000..92b7617 --- /dev/null +++ b/Trurl-based/Std/Mod/Log.txt @@ -0,0 +1,373 @@ +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/Trurl-based/Std/Mod/Logos.txt b/Trurl-based/Std/Mod/Logos.txt new file mode 100644 index 0000000..7f31e5b --- /dev/null +++ b/Trurl-based/Std/Mod/Logos.txt @@ -0,0 +1,162 @@ +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/Trurl-based/Std/Mod/Scrollers.txt b/Trurl-based/Std/Mod/Scrollers.txt new file mode 100644 index 0000000..46731aa --- /dev/null +++ b/Trurl-based/Std/Mod/Scrollers.txt @@ -0,0 +1,853 @@ +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/Trurl-based/Std/Mod/Stamps.txt b/Trurl-based/Std/Mod/Stamps.txt new file mode 100644 index 0000000..50bf0ea --- /dev/null +++ b/Trurl-based/Std/Mod/Stamps.txt @@ -0,0 +1,436 @@ +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/Trurl-based/Std/Mod/ViewSizer.txt b/Trurl-based/Std/Mod/ViewSizer.txt new file mode 100644 index 0000000..9d3f6fc --- /dev/null +++ b/Trurl-based/Std/Mod/ViewSizer.txt @@ -0,0 +1,133 @@ +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/Trurl-based/Std/Rsrc/Strings.odc b/Trurl-based/Std/Rsrc/Strings.odc new file mode 100644 index 0000000..714e832 Binary files /dev/null and b/Trurl-based/Std/Rsrc/Strings.odc differ diff --git a/Trurl-based/Std/Rsrc/ru/Strings.odc b/Trurl-based/Std/Rsrc/ru/Strings.odc new file mode 100644 index 0000000..286adde Binary files /dev/null and b/Trurl-based/Std/Rsrc/ru/Strings.odc differ diff --git a/Trurl-based/System/Docu/Config.odc b/Trurl-based/System/Docu/Config.odc new file mode 100644 index 0000000..381acf8 Binary files /dev/null and b/Trurl-based/System/Docu/Config.odc differ diff --git a/Trurl-based/System/Docu/Containers.odc b/Trurl-based/System/Docu/Containers.odc new file mode 100644 index 0000000..f018778 Binary files /dev/null and b/Trurl-based/System/Docu/Containers.odc differ diff --git a/Trurl-based/System/Docu/Controllers.odc b/Trurl-based/System/Docu/Controllers.odc new file mode 100644 index 0000000..fcef99f Binary files /dev/null and b/Trurl-based/System/Docu/Controllers.odc differ diff --git a/Trurl-based/System/Docu/Controls.odc b/Trurl-based/System/Docu/Controls.odc new file mode 100644 index 0000000..b2b7b25 Binary files /dev/null and b/Trurl-based/System/Docu/Controls.odc differ diff --git a/Trurl-based/System/Docu/Converters.odc b/Trurl-based/System/Docu/Converters.odc new file mode 100644 index 0000000..3d88f9b Binary files /dev/null and b/Trurl-based/System/Docu/Converters.odc differ diff --git a/Trurl-based/System/Docu/Dates.odc b/Trurl-based/System/Docu/Dates.odc new file mode 100644 index 0000000..1871992 Binary files /dev/null and b/Trurl-based/System/Docu/Dates.odc differ diff --git a/Trurl-based/System/Docu/Dialog.odc b/Trurl-based/System/Docu/Dialog.odc new file mode 100644 index 0000000..d509b1a Binary files /dev/null and b/Trurl-based/System/Docu/Dialog.odc differ diff --git a/Trurl-based/System/Docu/Documents.odc b/Trurl-based/System/Docu/Documents.odc new file mode 100644 index 0000000..5d10589 Binary files /dev/null and b/Trurl-based/System/Docu/Documents.odc differ diff --git a/Trurl-based/System/Docu/Files.odc b/Trurl-based/System/Docu/Files.odc new file mode 100644 index 0000000..8099a9d Binary files /dev/null and b/Trurl-based/System/Docu/Files.odc differ diff --git a/Trurl-based/System/Docu/Fonts.odc b/Trurl-based/System/Docu/Fonts.odc new file mode 100644 index 0000000..87e2347 Binary files /dev/null and b/Trurl-based/System/Docu/Fonts.odc differ diff --git a/Trurl-based/System/Docu/Init.odc b/Trurl-based/System/Docu/Init.odc new file mode 100644 index 0000000..0651c5d Binary files /dev/null and b/Trurl-based/System/Docu/Init.odc differ diff --git a/Trurl-based/System/Docu/Integers.odc b/Trurl-based/System/Docu/Integers.odc new file mode 100644 index 0000000..ce3bb07 Binary files /dev/null and b/Trurl-based/System/Docu/Integers.odc differ diff --git a/Trurl-based/System/Docu/Kernel.odc b/Trurl-based/System/Docu/Kernel.odc new file mode 100644 index 0000000..de3951d Binary files /dev/null and b/Trurl-based/System/Docu/Kernel.odc differ diff --git a/Trurl-based/System/Docu/Log.odc b/Trurl-based/System/Docu/Log.odc new file mode 100644 index 0000000..b2a761a Binary files /dev/null and b/Trurl-based/System/Docu/Log.odc differ diff --git a/Trurl-based/System/Docu/Math.odc b/Trurl-based/System/Docu/Math.odc new file mode 100644 index 0000000..c782616 Binary files /dev/null and b/Trurl-based/System/Docu/Math.odc differ diff --git a/Trurl-based/System/Docu/Mechanisms.odc b/Trurl-based/System/Docu/Mechanisms.odc new file mode 100644 index 0000000..155cb17 Binary files /dev/null and b/Trurl-based/System/Docu/Mechanisms.odc differ diff --git a/Trurl-based/System/Docu/Meta.odc b/Trurl-based/System/Docu/Meta.odc new file mode 100644 index 0000000..242a6e8 Binary files /dev/null and b/Trurl-based/System/Docu/Meta.odc differ diff --git a/Trurl-based/System/Docu/Models.odc b/Trurl-based/System/Docu/Models.odc new file mode 100644 index 0000000..19488ec Binary files /dev/null and b/Trurl-based/System/Docu/Models.odc differ diff --git a/Trurl-based/System/Docu/Ports.odc b/Trurl-based/System/Docu/Ports.odc new file mode 100644 index 0000000..229f9b8 Binary files /dev/null and b/Trurl-based/System/Docu/Ports.odc differ diff --git a/Trurl-based/System/Docu/Printers.odc b/Trurl-based/System/Docu/Printers.odc new file mode 100644 index 0000000..4b85631 Binary files /dev/null and b/Trurl-based/System/Docu/Printers.odc differ diff --git a/Trurl-based/System/Docu/Printing.odc b/Trurl-based/System/Docu/Printing.odc new file mode 100644 index 0000000..52d682d Binary files /dev/null and b/Trurl-based/System/Docu/Printing.odc differ diff --git a/Trurl-based/System/Docu/Properties.odc b/Trurl-based/System/Docu/Properties.odc new file mode 100644 index 0000000..96a1283 Binary files /dev/null and b/Trurl-based/System/Docu/Properties.odc differ diff --git a/Trurl-based/System/Docu/SMath.odc b/Trurl-based/System/Docu/SMath.odc new file mode 100644 index 0000000..14842e9 Binary files /dev/null and b/Trurl-based/System/Docu/SMath.odc differ diff --git a/Trurl-based/System/Docu/Sequencers.odc b/Trurl-based/System/Docu/Sequencers.odc new file mode 100644 index 0000000..1ef4a78 Binary files /dev/null and b/Trurl-based/System/Docu/Sequencers.odc differ diff --git a/Trurl-based/System/Docu/Services.odc b/Trurl-based/System/Docu/Services.odc new file mode 100644 index 0000000..a40f163 Binary files /dev/null and b/Trurl-based/System/Docu/Services.odc differ diff --git a/Trurl-based/System/Docu/Stores.odc b/Trurl-based/System/Docu/Stores.odc new file mode 100644 index 0000000..e1dd1c8 Binary files /dev/null and b/Trurl-based/System/Docu/Stores.odc differ diff --git a/Trurl-based/System/Docu/Strings.odc b/Trurl-based/System/Docu/Strings.odc new file mode 100644 index 0000000..436c8d2 Binary files /dev/null and b/Trurl-based/System/Docu/Strings.odc differ diff --git a/Trurl-based/System/Docu/Sys-Map.odc b/Trurl-based/System/Docu/Sys-Map.odc new file mode 100644 index 0000000..bc6e8ea Binary files /dev/null and b/Trurl-based/System/Docu/Sys-Map.odc differ diff --git a/Trurl-based/System/Docu/User-Man.odc b/Trurl-based/System/Docu/User-Man.odc new file mode 100644 index 0000000..55c4fe1 Binary files /dev/null and b/Trurl-based/System/Docu/User-Man.odc differ diff --git a/Trurl-based/System/Docu/Views.odc b/Trurl-based/System/Docu/Views.odc new file mode 100644 index 0000000..1cf4d7f Binary files /dev/null and b/Trurl-based/System/Docu/Views.odc differ diff --git a/Trurl-based/System/Docu/Windows.odc b/Trurl-based/System/Docu/Windows.odc new file mode 100644 index 0000000..bf094f8 Binary files /dev/null and b/Trurl-based/System/Docu/Windows.odc differ diff --git a/Trurl-based/System/Mod/Console.odc b/Trurl-based/System/Mod/Console.odc new file mode 100644 index 0000000..7089a54 Binary files /dev/null and b/Trurl-based/System/Mod/Console.odc differ diff --git a/Trurl-based/System/Mod/Console.txt b/Trurl-based/System/Mod/Console.txt new file mode 100644 index 0000000..25c983a --- /dev/null +++ b/Trurl-based/System/Mod/Console.txt @@ -0,0 +1,58 @@ +MODULE Console; + + (* THIS IS TEXT COPY OF Console.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.10 + + Interface based on OpenBUGS Console + *) + + TYPE + Console* = POINTER TO ABSTRACT RECORD END; + + VAR + cons: Console; + + (* Console *) + + PROCEDURE (c: Console) WriteStr- (IN s: ARRAY OF CHAR), NEW, ABSTRACT; + PROCEDURE (c: Console) WriteChar- (ch: CHAR), NEW, ABSTRACT; + PROCEDURE (c: Console) WriteLn-, NEW, ABSTRACT; + + (* + post: + s = "": end of input or input error + s # "": line with end of line postfix + *) + PROCEDURE (c: Console) ReadLn- (OUT s: ARRAY OF CHAR), NEW, ABSTRACT; + + + PROCEDURE WriteStr* (IN text: ARRAY OF CHAR); + BEGIN + cons.WriteStr(text) + END WriteStr; + + PROCEDURE WriteChar* (c: CHAR); + BEGIN + cons.WriteChar(c) + END WriteChar; + + PROCEDURE WriteLn*; + BEGIN + cons.WriteLn + END WriteLn; + + PROCEDURE ReadLn* (OUT text: ARRAY OF CHAR); + BEGIN + cons.ReadLn(text) + END ReadLn; + + + PROCEDURE SetConsole* (c: Console); + BEGIN + cons := c + END SetConsole; + +END Console. diff --git a/Trurl-based/System/Mod/Containers.txt b/Trurl-based/System/Mod/Containers.txt new file mode 100644 index 0000000..32270d5 --- /dev/null +++ b/Trurl-based/System/Mod/Containers.txt @@ -0,0 +1,1381 @@ +MODULE Containers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Containers.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, Services, Ports, Dialog, Stores, Models, Views, Controllers, Properties, Mechanisms; + + CONST + (** Controller.opts **) + noSelection* = 0; noFocus* = 1; noCaret* = 2; + mask* = {noSelection, noCaret}; layout* = {noFocus}; + modeOpts = {noSelection, noFocus, noCaret}; + + (** Controller.SelectAll select **) + deselect* = FALSE; select* = TRUE; + + (** Controller.PollNativeProp/etc. selection **) + any* = FALSE; selection* = TRUE; + + (** Mark/MarkCaret/MarkSelection/MarkSingleton show **) + hide* = FALSE; show* = TRUE; + + indirect = FALSE; direct = TRUE; + + TAB = 9X; LTAB = 0AX; ENTER = 0DX; ESC = 01BX; + PL = 10X; PR = 11X; PU = 12X; PD = 13X; + DL = 14X; DR = 15; DU = 16X; DD = 17X; + AL = 1CX; AR = 1DX; AU = 1EX; AD = 1FX; + + minVersion = 0; maxModelVersion = 0; maxViewVersion = 0; maxCtrlVersion = 0; + + (* buttons *) + left = 16; middle = 17; right = 18; alt = 28; (* same as in HostPorts! *) + + + TYPE + Model* = POINTER TO ABSTRACT RECORD (Models.Model) END; + + View* = POINTER TO ABSTRACT RECORD (Views.View) + model: Model; + controller: Controller; + alienCtrl: Stores.Store (* alienCtrl = NIL OR controller = NIL *) + END; + + Controller* = POINTER TO ABSTRACT RECORD (Controllers.Controller) + opts-: SET; + model: Model; (* connected iff model # NIL *) + view: View; + focus, singleton: Views.View; + bVis: BOOLEAN (* control visibility of focus/singleton border *) + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + PollFocusMsg = RECORD (Controllers.PollFocusMsg) + all: BOOLEAN; + ctrl: Controller + END; + + ViewOp = POINTER TO RECORD (Stores.Operation) + v: View; + controller: Controller; (* may be NIL *) + alienCtrl: Stores.Store + END; + + ControllerOp = POINTER TO RECORD (Stores.Operation) + c: Controller; + opts: SET + END; + + ViewMessage = ABSTRACT RECORD (Views.Message) END; + + FocusMsg = RECORD (ViewMessage) + set: BOOLEAN + END; + + SingletonMsg = RECORD (ViewMessage) + set: BOOLEAN + END; + + FadeMsg = RECORD (ViewMessage) + show: BOOLEAN + END; + + DropPref* = RECORD (Properties.Preference) + mode-: SET; + okToDrop*: BOOLEAN + END; + + GetOpts* = RECORD (Views.PropMessage) + valid*, opts*: SET + END; + + SetOpts* = RECORD (Views.PropMessage) + valid*, opts*: SET + END; + + + PROCEDURE ^ (v: View) SetController* (c: Controller), NEW; + PROCEDURE ^ (v: View) InitModel* (m: Model), NEW; + + PROCEDURE ^ Focus* (): Controller; + PROCEDURE ^ ClaimFocus (v: Views.View): BOOLEAN; + PROCEDURE ^ MarkFocus (c: Controller; f: Views.Frame; show: BOOLEAN); + PROCEDURE ^ MarkSingleton* (c: Controller; f: Views.Frame; show: BOOLEAN); + PROCEDURE ^ FadeMarks* (c: Controller; show: BOOLEAN); + PROCEDURE ^ CopyView (source: Controller; VAR view: Views.View; VAR w, h: INTEGER); + PROCEDURE ^ ThisProp (c: Controller; direct: BOOLEAN): Properties.Property; + PROCEDURE ^ SetProp (c: Controller; old, p: Properties.Property; direct: BOOLEAN); + + + PROCEDURE ^ (c: Controller) InitView* (v: Views.View), NEW; + PROCEDURE (c: Controller) InitView2* (v: Views.View), NEW, EMPTY; + PROCEDURE ^ (c: Controller) ThisView* (): View, NEW, EXTENSIBLE; + PROCEDURE ^ (c: Controller) ThisFocus* (): Views.View, NEW, EXTENSIBLE; + PROCEDURE ^ (c: Controller) ConsiderFocusRequestBy* (view: Views.View), NEW; + PROCEDURE ^ (c: Controller) RestoreMarks* (f: Views.Frame; l, t, r, b: INTEGER), NEW; + PROCEDURE ^ (c: Controller) Neutralize*, NEW; + (** called by view's Neutralize **) + PROCEDURE ^ (c: Controller) HandleModelMsg* (VAR msg: Models.Message), NEW, EXTENSIBLE; + (** called by view's HandleModelMsg after handling msg **) + PROCEDURE ^ (c: Controller) HandleViewMsg* (f: Views.Frame; VAR msg: Views.Message), NEW, EXTENSIBLE; + (** called by view's HandleViewMsg after handling msg **) + PROCEDURE ^ (c: Controller) HandleCtrlMsg* (f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View), NEW, EXTENSIBLE; + (** called by view's HandleCtrlMsg *before* handling msg; focus is respected/used by view **) + PROCEDURE ^ (c: Controller) HandlePropMsg* (VAR msg: Views.PropMessage), NEW, EXTENSIBLE; + (** called by view's HandlePropMsg after handling msg; controller can override view **) + + (** Model **) + + PROCEDURE (m: Model) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + m.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxModelVersion, thisVersion) + END Internalize; + + PROCEDURE (m: Model) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + m.Externalize^(wr); + wr.WriteVersion(maxModelVersion) + END Externalize; + + PROCEDURE (m: Model) GetEmbeddingLimits* (OUT minW, maxW, minH, maxH: INTEGER), NEW, ABSTRACT; + PROCEDURE (m: Model) ReplaceView* (old, new: Views.View), NEW, ABSTRACT; + PROCEDURE (m: Model) InitFrom- (source: Model), NEW, EMPTY; + + (** View **) + + PROCEDURE (v: View) AcceptableModel- (m: Model): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (v: View) InitModel2- (m: Model), NEW, EMPTY; + PROCEDURE (v: View) InitModel* (m: Model), NEW; + BEGIN + ASSERT((v.model = NIL) OR (v.model = m), 20); + ASSERT(m # NIL, 21); + ASSERT(v.AcceptableModel(m), 22); + v.model := m; + Stores.Join(v, m); + v.InitModel2(m) + END InitModel; + + + PROCEDURE (v: View) Externalize2- (VAR rd: Stores.Writer), NEW, EMPTY; + PROCEDURE(v: View) Internalize2- (VAR rd: Stores.Reader), NEW, EMPTY; + + PROCEDURE (v: View) Internalize- (VAR rd: Stores.Reader); + VAR st: Stores.Store; c: Controller; m: Model; thisVersion: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxViewVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadStore(st); ASSERT(st # NIL, 100); + IF ~(st IS Model) THEN + rd.TurnIntoAlien(Stores.alienComponent); + Stores.Report("#System:AlienModel", "", "", ""); + RETURN + END; + m := st(Model); + rd.ReadStore(st); + IF st = NIL THEN c := NIL; v.alienCtrl := NIL + ELSIF st IS Stores.Alien THEN + c := NIL; v.alienCtrl := st; Stores.Join(v, v.alienCtrl); + Stores.Report("#System:AlienControllerWarning", "", "", "") + ELSE c := st(Controller); v.alienCtrl := NIL + END; + v.InitModel(m); + IF c # NIL THEN v.SetController(c) ELSE v.controller := NIL END; + v.Internalize2(rd) + END Internalize; + + PROCEDURE (v: View) Externalize- (VAR wr: Stores.Writer); + BEGIN + ASSERT(v.model # NIL, 20); + v.Externalize^(wr); + wr.WriteVersion(maxViewVersion); + wr.WriteStore(v.model); + IF v.controller # NIL THEN wr.WriteStore(v.controller) + ELSE wr.WriteStore(v.alienCtrl) + END; + v.Externalize2(wr) + END Externalize; + + PROCEDURE (v: View) CopyFromModelView2- (source: Views.View; model: Models.Model), NEW, EMPTY; + + PROCEDURE (v: View) CopyFromModelView- (source: Views.View; model: Models.Model); + VAR c: Controller; + BEGIN + WITH source: View DO + v.InitModel(model(Model)); + IF source.controller # NIL THEN + c := Stores.CopyOf(source.controller)(Controller) + ELSE + c := NIL + END; + IF source.alienCtrl # NIL THEN v.alienCtrl := Stores.CopyOf(source.alienCtrl)(Stores.Alien) END; + IF c # NIL THEN v.SetController(c) ELSE v.controller := NIL END + END; + v.CopyFromModelView2(source, model) + END CopyFromModelView; + + PROCEDURE (v: View) ThisModel* (): Model, EXTENSIBLE; + BEGIN + RETURN v.model + END ThisModel; + + PROCEDURE (v: View) SetController* (c: Controller), NEW; + VAR op: ViewOp; + BEGIN + ASSERT(v.model # NIL, 20); + IF v.controller # c THEN + Stores.Join(v, c); + NEW(op); op.v := v; op.controller := c; op.alienCtrl := NIL; + Views.Do(v, "#System:ViewSetting", op) + END + END SetController; + + PROCEDURE (v: View) ThisController* (): Controller, NEW, EXTENSIBLE; + BEGIN + RETURN v.controller + END ThisController; + + PROCEDURE (v: View) GetRect* (f: Views.Frame; view: Views.View; OUT l, t, r, b: INTEGER), NEW, ABSTRACT; + + PROCEDURE (v: View) RestoreMarks* (f: Views.Frame; l, t, r, b: INTEGER); + BEGIN + IF v.controller # NIL THEN v.controller.RestoreMarks(f, l, t, r, b) END + END RestoreMarks; + + PROCEDURE (v: View) Neutralize*; + BEGIN + IF v.controller # NIL THEN v.controller.Neutralize END + END Neutralize; + + PROCEDURE (v: View) ConsiderFocusRequestBy- (view: Views.View); + BEGIN + IF v.controller # NIL THEN v.controller.ConsiderFocusRequestBy(view) END + END ConsiderFocusRequestBy; + + + PROCEDURE (v: View) HandleModelMsg2- (VAR msg: Models.Message), NEW, EMPTY; + PROCEDURE (v: View) HandleViewMsg2- (f: Views.Frame; VAR msg: Views.Message), NEW, EMPTY; + PROCEDURE (v: View) HandlePropMsg2- (VAR p: Properties.Message), NEW, EMPTY; + PROCEDURE (v: View) HandleCtrlMsg2- (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View), NEW, EMPTY; + + + PROCEDURE (v: View) HandleModelMsg- (VAR msg: Models.Message); + BEGIN + v.HandleModelMsg2(msg); + IF v.controller # NIL THEN v.controller.HandleModelMsg(msg) END + END HandleModelMsg; + + PROCEDURE (v: View) HandleViewMsg- (f: Views.Frame; VAR msg: Views.Message); + BEGIN + v.HandleViewMsg2(f, msg); + IF v.controller # NIL THEN v.controller.HandleViewMsg(f, msg) END + END HandleViewMsg; + + PROCEDURE (v: View) HandleCtrlMsg* (f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View); + BEGIN + IF v.controller # NIL THEN v.controller.HandleCtrlMsg(f, msg, focus) END; + v.HandleCtrlMsg2(f, msg, focus); + WITH msg: Controllers.PollSectionMsg DO + IF ~msg.focus THEN focus := NIL END + | msg: Controllers.ScrollMsg DO + IF ~msg.focus THEN focus := NIL END + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (v: View) HandlePropMsg- (VAR p: Properties.Message); + BEGIN + v.HandlePropMsg2(p); + IF v.controller # NIL THEN v.controller.HandlePropMsg(p) END + END HandlePropMsg ; + + + (** Controller **) + + PROCEDURE (c: Controller) Externalize2- (VAR rd: Stores.Writer), NEW, EMPTY; + PROCEDURE(c: Controller) Internalize2- (VAR rd: Stores.Reader), NEW, EMPTY; + + PROCEDURE (c: Controller) Internalize- (VAR rd: Stores.Reader); + VAR v: INTEGER; + BEGIN + c.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxCtrlVersion, v); + IF rd.cancelled THEN RETURN END; + rd.ReadSet(c.opts); + c.Internalize2(rd) + END Internalize; + + PROCEDURE (c: Controller) Externalize- (VAR wr: Stores.Writer); + BEGIN + c.Externalize^(wr); + wr.WriteVersion(maxCtrlVersion); + wr.WriteSet(c.opts); + c.Externalize2(wr) + END Externalize; + + PROCEDURE (c: Controller) CopyFrom- (source: Stores.Store), EXTENSIBLE; + BEGIN + WITH source: Controller DO + c.opts := source.opts; + c.focus := NIL; c.singleton := NIL; + c.bVis := FALSE + END + END CopyFrom; + + PROCEDURE (c: Controller) InitView* (v: Views.View), NEW; + VAR view: View; model: Model; + BEGIN + ASSERT((v = NIL) # (c.view = NIL) OR (v = c.view), 21); + IF c.view = NIL THEN + ASSERT(v IS View, 22); (* subclass may assert narrower type *) + view := v(View); + model := view.ThisModel(); ASSERT(model # NIL, 24); + c.view := view; c.model := model; + Stores.Join(c, c.view) + ELSE + c.view.Neutralize; c.view := NIL; c.model := NIL + END; + c.focus := NIL; c.singleton := NIL; c.bVis := FALSE; + c.InitView2(v) + END InitView; + + PROCEDURE (c: Controller) ThisView* (): View, NEW, EXTENSIBLE; + BEGIN + RETURN c.view + END ThisView; + + + (** options **) + + PROCEDURE (c: Controller) SetOpts* (opts: SET), NEW, EXTENSIBLE; + VAR op: ControllerOp; + BEGIN + IF c.view # NIL THEN + NEW(op); op.c := c; op.opts := opts; + Views.Do(c.view, "#System:ChangeOptions", op) + ELSE + c.opts := opts + END + END SetOpts; + + + (** subclass hooks **) + + PROCEDURE (c: Controller) GetContextType* (OUT type: Stores.TypeName), NEW, ABSTRACT; + PROCEDURE (c: Controller) GetValidOps* (OUT valid: SET), NEW, ABSTRACT; + PROCEDURE (c: Controller) NativeModel* (m: Models.Model): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (c: Controller) NativeView* (v: Views.View): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (c: Controller) NativeCursorAt* (f: Views.Frame; x, y: INTEGER): INTEGER, NEW, ABSTRACT; + PROCEDURE (c: Controller) PickNativeProp* (f: Views.Frame; x, y: INTEGER; VAR p: Properties.Property), NEW, EMPTY; + PROCEDURE (c: Controller) PollNativeProp* (selection: BOOLEAN; VAR p: Properties.Property; VAR truncated: BOOLEAN), NEW, EMPTY; + PROCEDURE (c: Controller) SetNativeProp* (selection: BOOLEAN; old, p: Properties.Property), NEW, EMPTY; + + PROCEDURE (c: Controller) MakeViewVisible* (v: Views.View), NEW, EMPTY; + + PROCEDURE (c: Controller) GetFirstView* (selection: BOOLEAN; OUT v: Views.View), NEW, ABSTRACT; + PROCEDURE (c: Controller) GetNextView* (selection: BOOLEAN; VAR v: Views.View), NEW, ABSTRACT; + + PROCEDURE (c: Controller) GetPrevView* (selection: BOOLEAN; VAR v: Views.View), NEW, EXTENSIBLE; + VAR p, q: Views.View; + BEGIN + ASSERT(v # NIL, 20); + c.GetFirstView(selection, p); + IF p # v THEN + WHILE (p # NIL) & (p # v) DO q := p; c.GetNextView(selection, p) END; + ASSERT(p # NIL, 21); + v := q + ELSE + v := NIL + END + END GetPrevView; + + PROCEDURE (c: Controller) CanDrop* (f: Views.Frame; x, y: INTEGER): BOOLEAN, NEW, EXTENSIBLE; + BEGIN + RETURN TRUE + END CanDrop; + + PROCEDURE (c: Controller) GetSelectionBounds* (f: Views.Frame; OUT x, y, w, h: INTEGER), NEW, EXTENSIBLE; + VAR g: Views.Frame; v: Views.View; + BEGIN + x := 0; y := 0; w := 0; h := 0; + v := c.singleton; + IF v # NIL THEN + g := Views.ThisFrame(f, v); + IF g # NIL THEN + x := g.gx - f.gx; y := g.gy - f.gy; + v.context.GetSize(w, h) + END + END + END GetSelectionBounds; + + PROCEDURE (c: Controller) MarkDropTarget* (src, dst: Views.Frame; + sx, sy, dx, dy, w, h, rx, ry: INTEGER; + type: Stores.TypeName; + isSingle, show: BOOLEAN), NEW, EMPTY; + + PROCEDURE (c: Controller) Drop* (src, dst: Views.Frame; sx, sy, dx, dy, w, h, rx, ry: INTEGER; + view: Views.View; isSingle: BOOLEAN), NEW, ABSTRACT; + + PROCEDURE (c: Controller) MarkPickTarget* (src, dst: Views.Frame; + sx, sy, dx, dy: INTEGER; show: BOOLEAN), NEW, EMPTY; + + PROCEDURE (c: Controller) TrackMarks* (f: Views.Frame; x, y: INTEGER; units, extend, add: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: Controller) Resize* (view: Views.View; l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (c: Controller) DeleteSelection*, NEW, ABSTRACT; + PROCEDURE (c: Controller) MoveLocalSelection* (src, dst: Views.Frame; sx, sy, dx, dy: INTEGER), NEW, ABSTRACT; + PROCEDURE (c: Controller) CopyLocalSelection* (src, dst: Views.Frame; sx, sy, dx, dy: INTEGER), NEW, ABSTRACT; + PROCEDURE (c: Controller) SelectionCopy* (): Model, NEW, ABSTRACT; + PROCEDURE (c: Controller) NativePaste* (m: Models.Model; f: Views.Frame), NEW, ABSTRACT; + PROCEDURE (c: Controller) ArrowChar* (f: Views.Frame; ch: CHAR; units, select: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: Controller) ControlChar* (f: Views.Frame; ch: CHAR), NEW, ABSTRACT; + PROCEDURE (c: Controller) PasteChar* (ch: CHAR), NEW, ABSTRACT; + PROCEDURE (c: Controller) PasteView* (f: Views.Frame; v: Views.View; w, h: INTEGER), NEW, ABSTRACT; + + + (** selection **) + + PROCEDURE (c: Controller) HasSelection* (): BOOLEAN, NEW, EXTENSIBLE; + (** extended by subclass to include intrinsic selections **) + BEGIN + ASSERT(c.model # NIL, 20); + RETURN c.singleton # NIL + END HasSelection; + + PROCEDURE (c: Controller) Selectable* (): BOOLEAN, NEW, ABSTRACT; + + PROCEDURE (c: Controller) Singleton* (): Views.View, NEW; (* LEAF *) + BEGIN + IF c = NIL THEN RETURN NIL + ELSE RETURN c.singleton + END + END Singleton; + + PROCEDURE (c: Controller) SetSingleton* (s: Views.View), NEW, EXTENSIBLE; + (** extended by subclass to adjust intrinsic selections **) + VAR con: Models.Context; msg: SingletonMsg; + BEGIN + ASSERT(c.model # NIL, 20); + ASSERT(~(noSelection IN c.opts), 21); + IF c.singleton # s THEN + IF s # NIL THEN + con := s.context; + ASSERT(con # NIL, 22); ASSERT(con.ThisModel() = c.model, 23); + c.view.Neutralize + ELSIF c.singleton # NIL THEN + c.bVis := FALSE; msg.set := FALSE; Views.Broadcast(c.view, msg) + END; + c.singleton := s; + IF s # NIL THEN c.bVis := TRUE; msg.set := TRUE; Views.Broadcast(c.view, msg) END + END + END SetSingleton; + + PROCEDURE (c: Controller) SelectAll* (select: BOOLEAN), NEW, ABSTRACT; + (** replaced by subclass to include intrinsic selections **) + + PROCEDURE (c: Controller) InSelection* (f: Views.Frame; x, y: INTEGER): BOOLEAN, NEW, ABSTRACT; + (** replaced by subclass to include intrinsic selections **) + + PROCEDURE (c: Controller) MarkSelection* (f: Views.Frame; show: BOOLEAN), NEW, EXTENSIBLE; + (** replaced by subclass to include intrinsic selections **) + BEGIN + MarkSingleton(c, f, show) + END MarkSelection; + + + (** focus **) + + PROCEDURE (c: Controller) ThisFocus* (): Views.View, NEW, EXTENSIBLE; + BEGIN + ASSERT(c.model # NIL, 20); + RETURN c.focus + END ThisFocus; + + PROCEDURE (c: Controller) SetFocus* (focus: Views.View), NEW; (* LEAF *) + VAR focus0: Views.View; con: Models.Context; msg: FocusMsg; + BEGIN + ASSERT(c.model # NIL, 20); + focus0 := c.focus; + IF focus # focus0 THEN + IF focus # NIL THEN + con := focus.context; + ASSERT(con # NIL, 21); ASSERT(con.ThisModel() = c.model, 22); + IF focus0 = NIL THEN c.view.Neutralize END + END; + IF focus0 # NIL THEN + IF ~Views.IsInvalid(focus0) THEN focus0.Neutralize END; + c.bVis := FALSE; msg.set := FALSE; Views.Broadcast(c.view, msg) + END; + c.focus := focus; + IF focus # NIL THEN + c.MakeViewVisible(focus); + c.bVis := TRUE; msg.set := TRUE; Views.Broadcast(c.view, msg) + END + END + END SetFocus; + + PROCEDURE (c: Controller) ConsiderFocusRequestBy* (view: Views.View), NEW; + VAR con: Models.Context; + BEGIN + ASSERT(c.model # NIL, 20); + ASSERT(view # NIL, 21); con := view.context; + ASSERT(con # NIL, 22); ASSERT(con.ThisModel() = c.model, 23); + IF c.focus = NIL THEN c.SetFocus(view) END + END ConsiderFocusRequestBy; + + + (** caret **) + + PROCEDURE (c: Controller) HasCaret* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (c: Controller) MarkCaret* (f: Views.Frame; show: BOOLEAN), NEW, ABSTRACT; + + + (** general marking protocol **) + + PROCEDURE CheckMaskFocus (c: Controller; f: Views.Frame; VAR focus: Views.View); + VAR v: Views.View; + BEGIN + IF f.mark & (c.opts * modeOpts = mask) & (c.model # NIL) & ((focus = NIL) OR ~ClaimFocus(focus)) THEN + c.GetFirstView(any, v); + WHILE (v # NIL) & ~ClaimFocus(v) DO c.GetNextView(any, v) END; + IF v # NIL THEN + c.SetFocus(v); + focus := v + ELSE c.SetFocus(NIL); focus := NIL + END + END + END CheckMaskFocus; + + PROCEDURE (c: Controller) Mark* (f: Views.Frame; l, t, r, b: INTEGER; show: BOOLEAN), NEW, EXTENSIBLE; + BEGIN + MarkFocus(c, f, show); c.MarkSelection(f, show); c.MarkCaret(f, show) + END Mark; + + PROCEDURE (c: Controller) RestoreMarks2- (f: Views.Frame; l, t, r, b: INTEGER), NEW, EMPTY; + PROCEDURE (c: Controller) RestoreMarks* (f: Views.Frame; l, t, r, b: INTEGER), NEW; + BEGIN + IF f.mark THEN + c.Mark(f, l, t, r, b, show); + c.RestoreMarks2(f, l, t, r, b) + END + END RestoreMarks; + + PROCEDURE (c: Controller) Neutralize2-, NEW, EMPTY; + (** caret needs to be removed by this method **) + + PROCEDURE (c: Controller) Neutralize*, NEW; + BEGIN + c.SetFocus(NIL); c.SelectAll(deselect); + c.Neutralize2 + END Neutralize; + + + (** message handlers **) + + PROCEDURE (c: Controller) HandleModelMsg* (VAR msg: Models.Message), NEW, EXTENSIBLE; + BEGIN + ASSERT(c.model # NIL, 20) + END HandleModelMsg; + + PROCEDURE (c: Controller) HandleViewMsg* (f: Views.Frame; VAR msg: Views.Message), NEW, EXTENSIBLE; + VAR g: Views.Frame; mark: Controllers.MarkMsg; + BEGIN + ASSERT(c.model # NIL, 20); + IF msg.view = c.view THEN + WITH msg: ViewMessage DO + WITH msg: FocusMsg DO + g := Views.ThisFrame(f, c.focus); + IF g # NIL THEN + IF msg.set THEN + MarkFocus(c, f, show); + mark.show := TRUE; mark.focus := TRUE; + Views.ForwardCtrlMsg(g, mark) + ELSE + mark.show := FALSE; mark.focus := TRUE; + Views.ForwardCtrlMsg(g, mark); + MarkFocus(c, f, hide) + END + END + | msg: SingletonMsg DO + MarkSingleton(c, f, msg.set) + | msg: FadeMsg DO + MarkFocus(c, f, msg.show); + MarkSingleton(c, f, msg.show) + END + ELSE + END + END + END HandleViewMsg; + + + PROCEDURE CollectControlPref (c: Controller; focus: Views.View; ch: CHAR; cyclic: BOOLEAN; + VAR v: Views.View; VAR getFocus, accepts: BOOLEAN); + VAR first, w: Views.View; p: Properties.ControlPref; back: BOOLEAN; + BEGIN + back := (ch = LTAB) OR (ch = AL) OR (ch = AU); first := c.focus; + IF first = NIL THEN + c.GetFirstView(any, first); + IF back THEN w := first; + WHILE w # NIL DO first := w; c.GetNextView(any, w) END + END + END; + v := first; + WHILE v # NIL DO + p.char := ch; p.focus := focus; + p.getFocus := (v # focus) & ((ch = TAB) OR (ch = LTAB)) & ClaimFocus(v); + p.accepts := (v = focus) & (ch # TAB) & (ch # LTAB); + Views.HandlePropMsg(v, p); + IF p.accepts OR (v # focus) & p.getFocus THEN + getFocus := p.getFocus; accepts := p.accepts; + RETURN + END; + IF back THEN c.GetPrevView(any, v) ELSE c.GetNextView(any, v) END; + IF cyclic & (v = NIL) THEN + c.GetFirstView(any, v); + IF back THEN w := v; + WHILE w # NIL DO v := w; c.GetNextView(any, w) END + END + END; + IF v = first THEN v := NIL END + END; + getFocus := FALSE; accepts := FALSE + END CollectControlPref; + + PROCEDURE (c: Controller) HandlePropMsg* (VAR msg: Properties.Message), NEW, EXTENSIBLE; + VAR v: Views.View; + BEGIN + ASSERT(c.model # NIL, 20); + WITH msg: Properties.PollMsg DO + msg.prop := ThisProp(c, indirect) + | msg: Properties.SetMsg DO + SetProp(c, msg.old, msg.prop, indirect) + | msg: Properties.FocusPref DO + IF {noSelection, noFocus, noCaret} - c.opts # {} THEN msg.setFocus := TRUE END + | msg: GetOpts DO + msg.valid := modeOpts; msg.opts := c.opts + | msg: SetOpts DO + c.SetOpts(c.opts - msg.valid + (msg.opts * msg.valid)) + | msg: Properties.ControlPref DO + IF c.opts * modeOpts = mask THEN + v := msg.focus; + IF v = c.view THEN v := c.focus END; + CollectControlPref(c, v, msg.char, FALSE, v, msg.getFocus, msg.accepts); + IF msg.getFocus THEN msg.accepts := TRUE END + END + ELSE + END + END HandlePropMsg; + + + (** Directory **) + + PROCEDURE (d: Directory) NewController* (opts: SET): Controller, NEW, ABSTRACT; + + PROCEDURE (d: Directory) New* (): Controller, NEW, EXTENSIBLE; + BEGIN + RETURN d.NewController({}) + END New; + + + (* ViewOp *) + + PROCEDURE (op: ViewOp) Do; + VAR v: View; c0, c1: Controller; a0, a1: Stores.Store; + BEGIN + v := op.v; c0 := v.controller; a0 := v.alienCtrl; c1 := op.controller; a1 := op.alienCtrl; + IF c0 # NIL THEN c0.InitView(NIL) END; + v.controller := c1; v.alienCtrl := a1; + op.controller := c0; op.alienCtrl := a0; + IF c1 # NIL THEN c1.InitView(v) END; + Views.Update(v, Views.keepFrames) + END Do; + + + (* ControllerOp *) + + PROCEDURE (op: ControllerOp) Do; + VAR c: Controller; opts: SET; + BEGIN + c := op.c; + opts := c.opts; c.opts := op.opts; op.opts := opts; + Views.Update(c.view, Views.keepFrames) + END Do; + + + (* Controller implementation support *) + + PROCEDURE BorderVisible (c: Controller; f: Views.Frame): BOOLEAN; + BEGIN + IF 31 IN c.opts THEN RETURN TRUE END; + IF f IS Views.RootFrame THEN RETURN FALSE END; + IF Services.Is(c.focus, "OleClient.View") THEN RETURN FALSE END; + RETURN TRUE + END BorderVisible; + + PROCEDURE MarkFocus (c: Controller; f: Views.Frame; show: BOOLEAN); + VAR focus: Views.View; f1: Views.Frame; l, t, r, b: INTEGER; + BEGIN + focus := c.focus; + IF f.front & (focus # NIL) & (~show OR c.bVis) & BorderVisible(c, f) & ~(noSelection IN c.opts) THEN + f1 := Views.ThisFrame(f, focus); + IF f1 # NIL THEN + c.bVis := show; + c.view.GetRect(f, focus, l, t, r, b); + IF (l # MAX(INTEGER)) & (t # MAX(INTEGER)) THEN + Mechanisms.MarkFocusBorder(f, focus, l, t, r, b, show) + END + END + END + END MarkFocus; + + PROCEDURE MarkSingleton* (c: Controller; f: Views.Frame; show: BOOLEAN); + VAR l, t, r, b: INTEGER; + BEGIN + IF (*(f.front OR f.target) &*) (~show OR c.bVis) & (c.singleton # NIL) THEN + c.bVis := show; + c.view.GetRect(f, c.singleton, l, t, r, b); + IF (l # MAX(INTEGER)) & (t # MAX(INTEGER)) THEN + Mechanisms.MarkSingletonBorder(f, c.singleton, l, t, r, b, show) + END + END + END MarkSingleton; + + PROCEDURE FadeMarks* (c: Controller; show: BOOLEAN); + VAR msg: FadeMsg; v: Views.View; fc: Controller; + BEGIN + IF (c.focus # NIL) OR (c.singleton # NIL) THEN + IF c.bVis # show THEN + IF ~show THEN + v := c.focus; + WHILE (v # NIL) & (v IS View) DO + fc := v(View).ThisController(); + fc.bVis := FALSE; v := fc.focus + END + END; + c.bVis := show; msg.show := show; Views.Broadcast(c.view, msg) + END + END + END FadeMarks; + + + (* handle controller messages in editor mode *) + + PROCEDURE ClaimFocus (v: Views.View): BOOLEAN; + VAR p: Properties.FocusPref; + BEGIN + p.atLocation := FALSE; + p.hotFocus := FALSE; p.setFocus := FALSE; + Views.HandlePropMsg(v, p); + RETURN p.setFocus + END ClaimFocus; + + PROCEDURE ClaimFocusAt (v: Views.View; f, g: Views.Frame; x, y: INTEGER; mask: BOOLEAN): BOOLEAN; + VAR p: Properties.FocusPref; + BEGIN + p.atLocation := TRUE; p.x := x + f.gx - g.gx; p.y := y + f.gy - g.gy; + p.hotFocus := FALSE; p.setFocus := FALSE; + Views.HandlePropMsg(v, p); + RETURN p.setFocus & (mask OR ~p.hotFocus) + END ClaimFocusAt; + + PROCEDURE NeedFocusAt (v: Views.View; f, g: Views.Frame; x, y: INTEGER): BOOLEAN; + VAR p: Properties.FocusPref; + BEGIN + p.atLocation := TRUE; p.x := x + f.gx - g.gx; p.y := y + f.gy - g.gy; + p.hotFocus := FALSE; p.setFocus := FALSE; + Views.HandlePropMsg(v, p); + RETURN p.hotFocus OR p.setFocus + END NeedFocusAt; + + + PROCEDURE TrackToResize (c: Controller; f: Views.Frame; v: Views.View; x, y: INTEGER; buttons: SET); + VAR minW, maxW, minH, maxH, l, t, r, b, w0, h0, w, h: INTEGER; op: INTEGER; sg, fc: Views.View; + BEGIN + c.model.GetEmbeddingLimits(minW, maxW, minH, maxH); + c.view.GetRect(f, v, l, t, r, b); + w0 := r - l; h0 := b - t; w := w0; h := h0; + Mechanisms.TrackToResize(f, v, minW, maxW, minH, maxH, l, t, r, b, op, x, y, buttons); + IF op = Mechanisms.resize THEN + sg := c.singleton; fc := c.focus; + c.Resize(v, l, t, r, b); + IF c.singleton # sg THEN c.SetSingleton(sg) END; + IF c.focus # fc THEN c.focus := fc; c.bVis := FALSE END (* delayed c.SetFocus(fc) *) + END + END TrackToResize; + + PROCEDURE TrackToDrop (c: Controller; f: Views.Frame; VAR x, y: INTEGER; buttons: SET; + VAR pass: BOOLEAN); + VAR dest: Views.Frame; m: Models.Model; v: Views.View; + x0, y0, x1, y1, w, h, rx, ry, destX, destY: INTEGER; op: INTEGER; isDown, isSingle: BOOLEAN; mo: SET; + BEGIN (* drag and drop c's selection: mouse is in selection *) + x0 := x; y0 := y; + REPEAT + f.Input(x1, y1, mo, isDown) + UNTIL ~isDown OR (ABS(x1 - x) > 3 * Ports.point) OR (ABS(y1 - y) > 3 * Ports.point); + pass := ~isDown; + IF ~pass THEN + v := c.Singleton(); + IF v = NIL THEN v := c.view; isSingle := FALSE + ELSE isSingle := TRUE + END; + c.GetSelectionBounds(f, rx, ry, w, h); + rx := x0 - rx; ry := y0 - ry; + IF rx < 0 THEN rx := 0 ELSIF rx > w THEN rx := w END; + IF ry < 0 THEN ry := 0 ELSIF ry > h THEN ry := h END; + IF noCaret IN c.opts THEN op := Mechanisms.copy ELSE op := 0 END; + Mechanisms.TrackToDrop(f, v, isSingle, w, h, rx, ry, dest, destX, destY, op, x, y, buttons); + IF (op IN {Mechanisms.copy, Mechanisms.move}) THEN (* copy or move selection *) + IF dest # NIL THEN + m := dest.view.ThisModel(); + IF (dest.view = c.view) OR (m # NIL) & (m = c.view.ThisModel()) THEN (* local drop *) + IF op = Mechanisms.copy THEN (* local copy *) + c.CopyLocalSelection(f, dest, x0, y0, destX, destY) + ELSIF op = Mechanisms.move THEN (* local move *) + c.MoveLocalSelection(f, dest, x0, y0, destX, destY) + END + ELSE (* non-local drop *) + CopyView(c, v, w, h); (* create copy of selection *) + IF (op = Mechanisms.copy) OR (noCaret IN c.opts) THEN (* drop copy *) + Controllers.Drop(x, y, f, x0, y0, v, isSingle, w, h, rx, ry) + ELSIF op = Mechanisms.move THEN (* drop copy and delete original *) + Controllers.Drop(x, y, f, x0, y0, v, isSingle, w, h, rx, ry); + c.DeleteSelection; + END + END + ELSIF (op = Mechanisms.move) & ~(noCaret IN c.opts) THEN + c.DeleteSelection + END + END + END + END TrackToDrop; + + PROCEDURE TrackToPick (c: Controller; f: Views.Frame; x, y: INTEGER; buttons: SET; + VAR pass: BOOLEAN); + VAR p: Properties.Property; dest: Views.Frame; x0, y0, x1, y1, destX, destY: INTEGER; + op: INTEGER; isDown: BOOLEAN; m: SET; + BEGIN + x0 := x; y0 := y; + REPEAT + f.Input(x1, y1, m, isDown) + UNTIL ~isDown OR (ABS(x1 - x) > 3 * Ports.point) OR (ABS(y1 - y) > 3 * Ports.point); + pass := ~isDown; + IF ~pass THEN + Mechanisms.TrackToPick(f, dest, destX, destY, op, x, y, buttons); + IF op IN {Mechanisms.pick, Mechanisms.pickForeign} THEN + Properties.Pick(x, y, f, x0, y0, p); + IF p # NIL THEN SetProp(c, NIL, p, direct) END + END + END + END TrackToPick; + + PROCEDURE MarkViews (f: Views.Frame); + VAR x, y: INTEGER; isDown: BOOLEAN; root: Views.RootFrame; m: SET; + BEGIN + root := Views.RootOf(f); + Views.MarkBorders(root); + REPEAT f.Input(x, y, m, isDown) UNTIL ~isDown; + Views.MarkBorders(root) + END MarkViews; + + PROCEDURE Track (c: Controller; f: Views.Frame; VAR msg: Controllers.TrackMsg; VAR focus: Views.View); + VAR res, l, t, r, b: INTEGER; cursor: INTEGER; sel: Views.View; obj: Views.Frame; + inSel, pass, extend, add, double, popup: BOOLEAN; + BEGIN + cursor := Mechanisms.outside; sel := c.Singleton(); + IF focus # NIL THEN + c.view.GetRect(f, focus, l, t, r, b); + IF (BorderVisible(c, f) OR (f IS Views.RootFrame)) & ~(noSelection IN c.opts) THEN + cursor := Mechanisms.FocusBorderCursor(f, focus, l, t, r, b, msg.x, msg.y) + ELSIF (msg.x >= l) & (msg.x <= r) & (msg.y >= t) & (msg.y <= b) THEN + cursor := Mechanisms.inside + END + ELSIF sel # NIL THEN + c.view.GetRect(f, sel, l, t, r, b); + cursor := Mechanisms.SelBorderCursor(f, sel, l, t, r, b, msg.x, msg.y) + END; + IF cursor >= 0 THEN + IF focus # NIL THEN + (* resize focus *) + TrackToResize(c, f, focus, msg.x, msg.y, msg.modifiers); + focus := NIL + ELSE + (* resize singleton *) + TrackToResize(c, f, sel, msg.x, msg.y, msg.modifiers) + END + ELSIF (focus # NIL) & (cursor = Mechanisms.inside) THEN + (* forward to focus *) + ELSE + IF (focus # NIL) & (c.opts * modeOpts # mask) THEN c.SetFocus(NIL) END; + focus := NIL; + inSel := c.InSelection(f, msg.x, msg.y); + extend := Controllers.extend IN msg.modifiers; + add := Controllers.modify IN msg.modifiers; + double := Controllers.doubleClick IN msg.modifiers; + popup := right IN msg.modifiers; + obj := Views.FrameAt(f, msg.x, msg.y); + IF ~inSel & (~extend OR (noSelection IN c.opts)) THEN + IF obj # NIL THEN + IF ~(noFocus IN c.opts) & NeedFocusAt(obj.view, f, obj, msg.x, msg.y) + & (~(alt IN msg.modifiers) OR (noSelection IN c.opts)) THEN + (* set hot focus *) + focus := obj.view; + IF ClaimFocusAt(focus, f, obj, msg.x, msg.y, c.opts * modeOpts = mask) THEN + (* set permanent focus *) + c.SelectAll(deselect); + c.SetFocus(focus) + END + END; + IF (focus = NIL) & ~add & ~(noSelection IN c.opts) THEN + (* select object *) + c.SelectAll(deselect); + c.SetSingleton(obj.view); inSel := TRUE + END + ELSIF ~add THEN c.SelectAll(deselect) + END + END; + IF focus = NIL THEN + IF inSel & double & (popup OR (alt IN msg.modifiers)) THEN (* properties *) + Dialog.Call("StdCmds.ShowProp", "", res) + ELSIF inSel & double & (obj # NIL) THEN (* primary verb *) + Dialog.Call("HostMenus.PrimaryVerb", "", res) + ELSIF ~inSel & (alt IN msg.modifiers) & extend THEN + MarkViews(f) + ELSE + IF inSel & ~extend THEN (* drag *) + IF (alt IN msg.modifiers) OR (middle IN msg.modifiers) THEN + IF ~(noCaret IN c.opts) THEN + TrackToPick(c, f, msg.x, msg.y, msg.modifiers, pass) + END + ELSE + TrackToDrop(c, f, msg.x, msg.y, msg.modifiers, pass) + END; + IF ~pass THEN RETURN END + END; + IF ~(noSelection IN c.opts) & (~inSel OR extend OR add OR (obj = NIL) & ~popup) THEN (* select *) + c.TrackMarks(f, msg.x, msg.y, double, extend, add) + END; + IF popup THEN Dialog.Call("HostMenus.PopupMenu", "", res) END + END + END + END + END Track; + + PROCEDURE CopyView (source: Controller; VAR view: Views.View; VAR w, h: INTEGER); + VAR s: Views.View; m: Model; v: View; p: Properties.BoundsPref; + BEGIN + s := source.Singleton(); + IF s # NIL THEN (* create a copy of singular selection *) + view := Views.CopyOf(s, Views.deep); s.context.GetSize(w, h) + ELSE (* create a copy of view with a copy of whole selection as contents *) + m := source.SelectionCopy(); + v := Views.CopyWithNewModel(source.view, m)(View); + p.w := Views.undefined; p.h := Views.undefined; Views.HandlePropMsg(v, p); + view := v; w := p.w; h := p.h + END + END CopyView; + + PROCEDURE Paste (c: Controller; f: Views.Frame; v: Views.View; w, h: INTEGER); + VAR m: Models.Model; + BEGIN + m := v.ThisModel(); + IF (m # NIL) & c.NativeModel(m) THEN + (* paste whole contents of source view *) + c.NativePaste(m, f) + ELSE + (* paste whole view *) + c.PasteView(f, v (* Views.CopyOf(v, Views.deep) *), w, h) + END + END Paste; + + PROCEDURE GetValidOps (c: Controller; VAR valid: SET); + BEGIN + valid := {}; c.GetValidOps(valid); + IF noCaret IN c.opts THEN + valid := valid + - {Controllers.pasteChar, Controllers.pasteChar, + Controllers.paste, Controllers.cut} + END + END GetValidOps; + + + PROCEDURE Transfer (c: Controller; f: Views.Frame; + VAR msg: Controllers.TransferMessage; VAR focus: Views.View); + VAR g: Views.Frame; inSelection: BOOLEAN; dMsg: DropPref; + BEGIN + focus := NIL; + g := Views.FrameAt(f, msg.x, msg.y); + WITH msg: Controllers.PollDropMsg DO + inSelection := c.InSelection(f, msg.x, msg.y); + dMsg.mode := c.opts; dMsg.okToDrop := FALSE; + IF g # NIL THEN Views.HandlePropMsg(g.view, dMsg) END; + IF (g # NIL) & ~inSelection & (dMsg.okToDrop OR ~(noFocus IN c.opts))THEN + focus := g.view + ELSIF ~(noCaret IN c.opts) & c.CanDrop(f, msg.x, msg.y) THEN + msg.dest := f; + IF msg.mark THEN + c.MarkDropTarget(msg.source, f, msg.sourceX, msg.sourceY, msg.x, msg.y, msg.w, msg.h, msg.rx, msg.ry, + msg.type, msg.isSingle, msg.show) + END + END + | msg: Controllers.DropMsg DO + inSelection := c.InSelection(f, msg.x, msg.y); + dMsg.mode := c.opts; dMsg.okToDrop := FALSE; + IF g # NIL THEN Views.HandlePropMsg(g.view, dMsg) END; + IF (g # NIL) & ~inSelection & (dMsg.okToDrop OR ~(noFocus IN c.opts))THEN + focus := g.view + ELSIF ~(noCaret IN c.opts) & c.CanDrop(f, msg.x, msg.y) THEN + c.Drop(msg.source, f, msg.sourceX, msg.sourceY, msg.x, msg.y, msg.w, msg.h, + msg.rx, msg.ry, msg.view, msg.isSingle) + END + | msg: Properties.PollPickMsg DO + IF g # NIL THEN + focus := g.view + ELSE + msg.dest := f; + IF msg.mark THEN + c.MarkPickTarget(msg.source, f, msg.sourceX, msg.sourceY, msg.x, msg.y, msg.show) + END + END + | msg: Properties.PickMsg DO + IF g # NIL THEN + focus := g.view + ELSE + c.PickNativeProp(f, msg.x, msg.y, msg.prop) + END + ELSE + IF g # NIL THEN focus := g.view END + END + END Transfer; + + PROCEDURE FocusHasSel (): BOOLEAN; + VAR msg: Controllers.PollOpsMsg; + BEGIN + Controllers.PollOps(msg); + RETURN msg.selectable & (Controllers.copy IN msg.valid) + END FocusHasSel; + + PROCEDURE FocusEditor (): Controller; + VAR msg: PollFocusMsg; + BEGIN + msg.focus := NIL; msg.ctrl := NIL; msg.all := FALSE; + Controllers.Forward(msg); + RETURN msg.ctrl + END FocusEditor; + + PROCEDURE Edit (c: Controller; f: Views.Frame; + VAR msg: Controllers.EditMsg; VAR focus: Views.View); + VAR g: Views.Frame; v: Views.View; res: INTEGER; + valid: SET; select, units, getFocus, accepts: BOOLEAN; + sel: Controllers.SelectMsg; + BEGIN + IF (c.opts * modeOpts # mask) & (focus = NIL) THEN + IF (msg.op = Controllers.pasteChar) & (msg.char = ESC) THEN + c.SelectAll(FALSE) + ELSIF (c.Singleton() # NIL) & (msg.op = Controllers.pasteChar) & + (msg.char = ENTER) THEN + Dialog.Call("HostMenus.PrimaryVerb", "", res) + ELSE + GetValidOps(c, valid); + IF msg.op IN valid THEN + CASE msg.op OF + | Controllers.pasteChar: + IF msg.char >= " " THEN + c.PasteChar(msg.char) + ELSIF (AL <= msg.char) & (msg.char <= AD) OR + (PL <= msg.char) & (msg.char <= DD) THEN + select := Controllers.extend IN msg.modifiers; + units := Controllers.modify IN msg.modifiers; + c.ArrowChar(f, msg.char, units, select) + ELSE c.ControlChar(f, msg.char) + END + | Controllers.cut, Controllers.copy: + CopyView(c, msg.view, msg.w, msg.h); + msg.isSingle := c.Singleton() # NIL; + IF msg.op = Controllers.cut THEN c.DeleteSelection END + | Controllers.paste: + IF msg.isSingle THEN + c.PasteView(f, msg.view (* Views.CopyOf(msg.view, Views.deep) *), msg.w, msg.h) + ELSE + Paste(c, f, msg.view, msg.w, msg.h) + END + ELSE + END + END + END + ELSIF (c.opts * modeOpts # mask) + & (msg.op = Controllers.pasteChar) & (msg.char = ESC) + & (~(f IS Views.RootFrame) OR (31 IN c.opts)) + & (c = FocusEditor()) + & ((Controllers.extend IN msg.modifiers) OR ~FocusHasSel()) THEN + IF 31 IN c.opts THEN INCL(msg.modifiers, 31) + ELSE c.SetSingleton(focus) + END; + focus := NIL + ELSIF (c.opts * modeOpts # mask) & (c = Focus()) THEN + (* do some generic processing for non-container views *) + IF (msg.op = Controllers.pasteChar) & (msg.char = ESC) THEN + g := Views.ThisFrame(f, focus); + IF g # NIL THEN sel.set := FALSE; Views.ForwardCtrlMsg(g, sel) END + END + ELSIF (c.opts * modeOpts = mask) & (msg.op = Controllers.pasteChar) THEN + IF alt IN msg.modifiers THEN + CollectControlPref (c, NIL, msg.char, TRUE, v, getFocus, accepts) + ELSE + CollectControlPref (c, focus, msg.char, TRUE, v, getFocus, accepts) + END; + IF v = NIL THEN + CheckMaskFocus(c, f, focus); + CollectControlPref(c, focus, msg.char, TRUE, v, getFocus, accepts) + END; + IF v # NIL THEN + IF getFocus & (v # focus) THEN + c.SetFocus(v) + END; + IF accepts THEN + g := Views.ThisFrame(f, v); + IF g # NIL THEN Views.ForwardCtrlMsg(g, msg) END + END; + focus := NIL + END + END + END Edit; + + PROCEDURE PollCursor (c: Controller; f: Views.Frame; VAR msg: Controllers.PollCursorMsg; VAR focus: Views.View); + VAR l, t, r, b: INTEGER; cursor: INTEGER; sel: Views.View; obj: Views.Frame; inSel: BOOLEAN; + BEGIN + cursor := Mechanisms.outside; sel := c.Singleton(); + IF focus # NIL THEN + c.view.GetRect(f, focus, l, t, r, b); + IF (BorderVisible(c, f) OR (f IS Views.RootFrame)) & ~(noSelection IN c.opts) THEN + cursor := Mechanisms.FocusBorderCursor(f, focus, l, t, r, b, msg.x, msg.y) + ELSIF (msg.x >= l) & (msg.x <= r) & (msg.y >= t) & (msg.y <= b) THEN + cursor := Mechanisms.inside + END + ELSIF sel # NIL THEN + c.view.GetRect(f, sel, l, t, r, b); + cursor := Mechanisms.SelBorderCursor(f, sel, l, t, r, b, msg.x, msg.y) + END; + IF cursor >= 0 THEN + msg.cursor := cursor; focus := NIL + ELSIF (focus # NIL) & (cursor = Mechanisms.inside) THEN + msg.cursor := Ports.arrowCursor + ELSE + IF noCaret IN c.opts THEN msg.cursor := Ports.arrowCursor + ELSE msg.cursor := c.NativeCursorAt(f, msg.x, msg.y) (* if nothing else, use native cursor *) + END; + focus := NIL; inSel := FALSE; + IF ~(noSelection IN c.opts) THEN inSel := c.InSelection(f, msg.x, msg.y) END; + IF ~inSel THEN + obj := Views.FrameAt(f, msg.x, msg.y); + IF obj # NIL THEN + IF ~(noFocus IN c.opts) & NeedFocusAt(obj.view, f, obj, msg.x, msg.y) THEN + focus := obj.view; + msg.cursor := Ports.arrowCursor + ELSIF ~(noSelection IN c.opts) THEN + inSel := TRUE + END + END + END; + IF focus = NIL THEN + IF inSel THEN + msg.cursor := Ports.arrowCursor + END + END + END + END PollCursor; + + PROCEDURE PollOps (c: Controller; f: Views.Frame; + VAR msg: Controllers.PollOpsMsg; VAR focus: Views.View); + BEGIN + IF focus = NIL THEN + msg.type := ""; + IF ~(noSelection IN c.opts) THEN c.GetContextType(msg.type) END; + msg.selectable := ~(noSelection IN c.opts) & c.Selectable(); + GetValidOps(c, msg.valid); + msg.singleton := c.Singleton() + END + END PollOps; + + PROCEDURE ReplaceView (c: Controller; old, new: Views.View); + BEGIN + ASSERT(old.context # NIL, 20); + ASSERT((new.context = NIL) OR (new.context = old.context), 22); + IF old.context.ThisModel() = c.model THEN + c.model.ReplaceView(old, new) + END; + IF c.singleton = old THEN c.singleton := new END; + IF c.focus = old THEN c.focus := new END + END ReplaceView; + + PROCEDURE ViewProp (v: Views.View): Properties.Property; + VAR poll: Properties.PollMsg; + BEGIN + poll.prop := NIL; Views.HandlePropMsg(v, poll); RETURN poll.prop + END ViewProp; + + PROCEDURE SetViewProp (v: Views.View; old, p: Properties.Property); + VAR set: Properties.SetMsg; + BEGIN + set.old := old; set.prop := p; Views.HandlePropMsg(v, set) + END SetViewProp; + + PROCEDURE SizeProp (v: Views.View): Properties.Property; + VAR sp: Properties.SizeProp; + BEGIN + NEW(sp); sp.known := {Properties.width, Properties.height}; sp.valid := sp.known; + v.context.GetSize(sp.width, sp.height); + RETURN sp + END SizeProp; + + PROCEDURE SetSizeProp (v: Views.View; p: Properties.SizeProp); + VAR w, h: INTEGER; + BEGIN + IF p.valid # {Properties.width, Properties.height} THEN + v.context.GetSize(w, h) + END; + IF Properties.width IN p.valid THEN w := p.width END; + IF Properties.height IN p.valid THEN h := p.height END; + v.context.SetSize(w, h) + END SetSizeProp; + + PROCEDURE ThisProp (c: Controller; direct: BOOLEAN): Properties.Property; + CONST scanCutoff = MAX(INTEGER) (* 50 *); (* bound number of polled embedded views *) + VAR v: Views.View; np, vp, p: Properties.Property; k: INTEGER; trunc, equal: BOOLEAN; + BEGIN + trunc := FALSE; k := 1; + np := NIL; c.PollNativeProp(direct, np, trunc); + v := NIL; c.GetFirstView(direct, v); + IF v # NIL THEN + Properties.Insert(np, SizeProp(v)); + vp := ViewProp(v); + k := scanCutoff; c.GetNextView(direct, v); + WHILE (v # NIL) & (k > 0) DO + DEC(k); + Properties.Insert(np, SizeProp(v)); + Properties.Intersect(vp, ViewProp(v), equal); + c.GetNextView(direct, v) + END; + IF c.singleton # NIL THEN Properties.Merge(np, vp); vp := np + ELSE Properties.Merge(vp, np) + END + ELSE vp := np + END; + IF trunc OR (k = 0) THEN + p := vp; WHILE p # NIL DO p.valid := {}; p := p.next END + END; + IF noCaret IN c.opts THEN + p := vp; WHILE p # NIL DO p.readOnly := p.valid; p := p.next END + END; + RETURN vp + END ThisProp; + + PROCEDURE SetProp (c: Controller; old, p: Properties.Property; direct: BOOLEAN); + TYPE + ViewList = POINTER TO RECORD next: ViewList; view: Views.View END; + VAR v: Views.View; q, sp: Properties.Property; equal: BOOLEAN; s: Stores.Operation; + list, last: ViewList; + BEGIN + IF noCaret IN c.opts THEN RETURN END; + Views.BeginScript(c.view, "#System:SetProp", s); + q := p; WHILE (q # NIL) & ~(q IS Properties.SizeProp) DO q := q.next END; + list := NIL; v := NIL; c.GetFirstView(direct, v); + WHILE v # NIL DO + IF list = NIL THEN NEW(list); last := list + ELSE NEW(last.next); last := last.next + END; + last.view := v; + c.GetNextView(direct, v) + END; + c.SetNativeProp(direct, old, p); + WHILE list # NIL DO + v := list.view; list := list.next; + SetViewProp(v, old, p); + IF direct & (q # NIL) THEN + (* q IS Properties.SizeProp *) + IF old # NIL THEN + sp := SizeProp(v); + Properties.Intersect(sp, old, equal); + Properties.Intersect(sp, old, equal) + END; + IF (old = NIL) OR equal THEN + SetSizeProp(v, q(Properties.SizeProp)) + END + END + END; + Views.EndScript(c.view, s) + END SetProp; + + PROCEDURE (c: Controller) HandleCtrlMsg* (f: Views.Frame; + VAR msg: Controllers.Message; VAR focus: Views.View), NEW, EXTENSIBLE; + BEGIN + focus := c.focus; + WITH msg: Controllers.PollCursorMsg DO + PollCursor(c, f, msg, focus) + | msg: Controllers.PollOpsMsg DO + PollOps(c, f, msg, focus) + | msg: PollFocusMsg DO + IF msg.all OR (c.opts * modeOpts # mask) & (c.focus # NIL) THEN msg.ctrl := c END + | msg: Controllers.TrackMsg DO + Track(c, f, msg, focus) + | msg: Controllers.EditMsg DO + Edit(c, f, msg, focus) + | msg: Controllers.TransferMessage DO + Transfer(c, f, msg, focus) + | msg: Controllers.SelectMsg DO + IF focus = NIL THEN c.SelectAll(msg.set) END + | msg: Controllers.TickMsg DO + FadeMarks(c, show); + CheckMaskFocus(c, f, focus) + | msg: Controllers.MarkMsg DO + c.bVis := msg.show; + c.Mark(f, f.l, f.t, f.r, f.b, msg.show) + | msg: Controllers.ReplaceViewMsg DO + ReplaceView(c, msg.old, msg.new) + | msg: Properties.CollectMsg DO + IF focus = NIL THEN + msg.poll.prop := ThisProp(c, direct) + END + | msg: Properties.EmitMsg DO + IF focus = NIL THEN + SetProp(c, msg.set.old, msg.set.prop, direct) + END + ELSE + END + END HandleCtrlMsg; + + + (** miscellaneous **) + + PROCEDURE Focus* (): Controller; + VAR msg: PollFocusMsg; + BEGIN + msg.focus := NIL; msg.ctrl := NIL; msg.all := TRUE; + Controllers.Forward(msg); + RETURN msg.ctrl + END Focus; + + PROCEDURE FocusSingleton* (): Views.View; + VAR c: Controller; v: Views.View; + BEGIN + c := Focus(); + IF c # NIL THEN v := c.Singleton() ELSE v := NIL END; + RETURN v + END FocusSingleton; + + PROCEDURE CloneOf* (m: Model): Model; + VAR h: Model; + BEGIN + ASSERT(m # NIL, 20); + Kernel.NewObj(h, Kernel.TypeOf(m)); + h.InitFrom(m); + RETURN h + END CloneOf; + +END Containers. diff --git a/Trurl-based/System/Mod/Controllers.txt b/Trurl-based/System/Mod/Controllers.txt new file mode 100644 index 0000000..c0eed4e --- /dev/null +++ b/Trurl-based/System/Mod/Controllers.txt @@ -0,0 +1,426 @@ +MODULE Controllers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Controllers.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, Services, Ports, Stores, Models, Views; + + CONST + (** Forward target **) + targetPath* = TRUE; frontPath* = FALSE; + + (** ScrollMsg.op **) + decLine* = 0; incLine* = 1; decPage* = 2; incPage* = 3; gotoPos* = 4; + + (** PageMsg.op **) + nextPageX* = 0; nextPageY* = 1; gotoPageX* = 2; gotoPageY* = 3; + + (** PollOpsMsg.valid, EditMsg.op **) + cut* = 0; copy* = 1; + pasteChar* = 2; (* pasteLChar* = 3; *) paste* = 4; (* pasteView* = 5; *) + + (** TrackMsg.modifiers, EditMsg.modifiers **) + doubleClick* = 0; (** clicking history **) + extend* = 1; modify* = 2; (** modifier keys **) + (* extend = Sub.extend; modify = Sub.modify *) + + (** PollDropMsg.mark, PollDrop mark **) + noMark* = FALSE; mark* = TRUE; + (** PollDropMsg.show, PollDrop show **) + hide* = FALSE; show* = TRUE; + + minVersion = 0; maxVersion = 0; + + + TYPE + + (** messages **) + + Message* = Views.CtrlMessage; + + PollFocusMsg* = EXTENSIBLE RECORD (Message) + focus*: Views.Frame (** OUT, preset to NIL **) + END; + + PollSectionMsg* = RECORD (Message) + focus*, vertical*: BOOLEAN; (** IN **) + wholeSize*: INTEGER; (** OUT, preset to 1 **) + partSize*: INTEGER; (** OUT, preset to 1 **) + partPos*: INTEGER; (** OUT, preset to 0 **) + valid*, done*: BOOLEAN (** OUT, preset to (FALSE, FALSE) **) + END; + + PollOpsMsg* = RECORD (Message) + type*: Stores.TypeName; (** OUT, preset to "" **) + pasteType*: Stores.TypeName; (** OUT, preset to "" **) + singleton*: Views.View; (** OUT, preset to NIL **) + selectable*: BOOLEAN; (** OUT, preset to FALSE **) + valid*: SET (** OUT, preset to {} **) + END; + + ScrollMsg* = RECORD (Message) + focus*, vertical*: BOOLEAN; (** IN **) + op*: INTEGER; (** IN **) + pos*: INTEGER; (** IN **) + done*: BOOLEAN (** OUT, preset to FALSE **) + END; + + PageMsg* = RECORD (Message) + op*: INTEGER; (** IN **) + pageX*, pageY*: INTEGER; (** IN **) + done*, eox*, eoy*: BOOLEAN (** OUT, preset to (FALSE, FALSE, FALSE) **) + END; + + TickMsg* = RECORD (Message) + tick*: INTEGER (** IN **) + END; + + MarkMsg* = RECORD (Message) + show*: BOOLEAN; (** IN **) + focus*: BOOLEAN (** IN **) + END; + + SelectMsg* = RECORD (Message) + set*: BOOLEAN (** IN **) + END; + + + RequestMessage* = ABSTRACT RECORD (Message) + requestFocus*: BOOLEAN (** OUT, preset (by framework) to FALSE **) + END; + + EditMsg* = RECORD (RequestMessage) + op*: INTEGER; (** IN **) + modifiers*: SET; (** IN, valid if op IN {pasteChar, pasteLchar} **) + char*: CHAR; (** IN, valid if op = pasteChar **) + view*: Views.View; w*, h*: INTEGER; (** IN, valid if op = paste **) + (** OUT, valid if op IN {cut, copy} **) + isSingle*: BOOLEAN; (** dito **) + clipboard*: BOOLEAN (** IN, valid if op IN {cut, copy, paste} **) + END; + + ReplaceViewMsg* = RECORD (RequestMessage) + old*, new*: Views.View (** IN **) + END; + + + CursorMessage* = ABSTRACT RECORD (RequestMessage) + x*, y*: INTEGER (** IN, needs translation when passed on **) + END; + + PollCursorMsg* = RECORD (CursorMessage) + cursor*: INTEGER; (** OUT, preset to Ports.arrowCursor **) + modifiers*: SET (** IN **) + END; + + TrackMsg* = RECORD (CursorMessage) + modifiers*: SET (** IN **) + END; + + WheelMsg* = RECORD (CursorMessage) + done*: BOOLEAN; (** must be set if the message is handled **) + op*, nofLines*: INTEGER; + END; + + + TransferMessage* = ABSTRACT RECORD (CursorMessage) + source*: Views.Frame; (** IN, home frame of transfer originator, may be NIL if unknown **) + sourceX*, sourceY*: INTEGER (** IN, reference point in source frame, defined if source # NIL **) + END; + + PollDropMsg* = RECORD (TransferMessage) + mark*: BOOLEAN; (** IN, request to mark drop target **) + show*: BOOLEAN; (** IN, if mark then show/hide target mark **) + type*: Stores.TypeName; (** IN, type of view to drop **) + isSingle*: BOOLEAN; (** IN, view to drop is singleton **) + w*, h*: INTEGER; (** IN, size of view to drop, may be 0, 0 **) + rx*, ry*: INTEGER; (** IN, reference point in view **) + dest*: Views.Frame (** OUT, preset to NIL, set if DropMsg is acceptable **) + END; + + DropMsg* = RECORD (TransferMessage) + view*: Views.View; (** IN, drop this *) + isSingle*: BOOLEAN; (** IN, view to drop is singleton **) + w*, h*: INTEGER; (** IN, proposed size *) + rx*, ry*: INTEGER (** IN, reference point in view **) + END; + + + (** controllers **) + + Controller* = POINTER TO ABSTRACT RECORD (Stores.Store) END; + + + (** forwarders **) + + Forwarder* = POINTER TO ABSTRACT RECORD + next: Forwarder + END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + PathInfo = POINTER TO RECORD + path: BOOLEAN; prev: PathInfo + END; + + BalanceCheckAction = POINTER TO RECORD (Services.Action) + wait: WaitAction + END; + WaitAction = POINTER TO RECORD (Services.Action) + check: BalanceCheckAction + END; + + VAR + path-: BOOLEAN; + + list: Forwarder; + + cleaner: TrapCleaner; + prevPath, cache: PathInfo; + + + + (** BalanceCheckAction **) + + PROCEDURE (a: BalanceCheckAction) Do; + BEGIN + Services.DoLater(a.wait, Services.resolution); + ASSERT(prevPath = NIL, 100); + END Do; + + PROCEDURE (a: WaitAction) Do; + BEGIN + Services.DoLater(a.check, Services.immediately) + END Do; + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + path := frontPath; + prevPath := NIL + END Cleanup; + + PROCEDURE NewPathInfo(): PathInfo; + VAR c: PathInfo; + BEGIN + IF cache = NIL THEN NEW(c) + ELSE c := cache; cache := cache.prev + END; + RETURN c + END NewPathInfo; + + PROCEDURE DisposePathInfo(c: PathInfo); + BEGIN + c.prev := cache; cache := c + END DisposePathInfo; + + + (** Controller **) + + PROCEDURE (c: Controller) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + (** pre: ~c.init **) + (** post: c.init **) + VAR thisVersion: INTEGER; + BEGIN + c.Internalize^(rd); + rd.ReadVersion(minVersion, maxVersion, thisVersion) + END Internalize; + + PROCEDURE (c: Controller) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + (** pre: c.init **) + BEGIN + c.Externalize^(wr); + wr.WriteVersion(maxVersion) + END Externalize; + + + (** Forwarder **) + + PROCEDURE (f: Forwarder) Forward* (target: BOOLEAN; VAR msg: Message), NEW, ABSTRACT; + PROCEDURE (f: Forwarder) Transfer* (VAR msg: TransferMessage), NEW, ABSTRACT; + + PROCEDURE Register* (f: Forwarder); + VAR t: Forwarder; + BEGIN + ASSERT(f # NIL, 20); + t := list; WHILE (t # NIL) & (t # f) DO t := t.next END; + IF t = NIL THEN f.next := list; list := f END + END Register; + + PROCEDURE Delete* (f: Forwarder); + VAR t: Forwarder; + BEGIN + ASSERT(f # NIL, 20); + IF f = list THEN + list := list.next + ELSE + t := list; WHILE (t # NIL) & (t.next # f) DO t := t.next END; + IF t # NIL THEN t.next := f.next END + END; + f.next := NIL + END Delete; + + + PROCEDURE ForwardVia* (target: BOOLEAN; VAR msg: Message); + VAR t: Forwarder; + BEGIN + t := list; WHILE t # NIL DO t.Forward(target, msg); t := t.next END + END ForwardVia; + + PROCEDURE SetCurrentPath* (target: BOOLEAN); + VAR p: PathInfo; + BEGIN + IF prevPath = NIL THEN Kernel.PushTrapCleaner(cleaner) END; + p := NewPathInfo(); p.prev := prevPath; prevPath := p; p.path := path; + path := target + END SetCurrentPath; + + PROCEDURE ResetCurrentPath*; + VAR p: PathInfo; + BEGIN + IF prevPath # NIL THEN (* otherwise trap cleaner may have already removed prefPath objects *) + p := prevPath; prevPath := p.prev; path := p.path; + IF prevPath = NIL THEN Kernel.PopTrapCleaner(cleaner) END; + DisposePathInfo(p) + END + END ResetCurrentPath; + + PROCEDURE Forward* (VAR msg: Message); + BEGIN + ForwardVia(path, msg) + END Forward; + + PROCEDURE PollOps* (VAR msg: PollOpsMsg); + BEGIN + msg.type := ""; + msg.pasteType := ""; + msg.singleton := NIL; + msg.selectable := FALSE; + msg.valid := {}; + Forward(msg) + END PollOps; + + PROCEDURE PollCursor* (x, y: INTEGER; modifiers: SET; OUT cursor: INTEGER); + VAR msg: PollCursorMsg; + BEGIN + msg.x := x; msg.y := y; msg.cursor := Ports.arrowCursor; msg.modifiers := modifiers; + Forward(msg); + cursor := msg.cursor + END PollCursor; + + PROCEDURE Transfer* (x, y: INTEGER; source: Views.Frame; sourceX, sourceY: INTEGER; VAR msg: TransferMessage); + VAR t: Forwarder; + BEGIN + ASSERT(source # NIL, 20); + msg.x := x; msg.y := y; + msg.source := source; msg.sourceX := sourceX; msg.sourceY := sourceY; + t := list; WHILE t # NIL DO t.Transfer(msg); t := t.next END + END Transfer; + + PROCEDURE PollDrop* (x, y: INTEGER; + source: Views.Frame; sourceX, sourceY: INTEGER; + mark, show: BOOLEAN; + type: Stores.TypeName; + isSingle: BOOLEAN; + w, h, rx, ry: INTEGER; + OUT dest: Views.Frame; OUT destX, destY: INTEGER); + VAR msg: PollDropMsg; + BEGIN + ASSERT(source # NIL, 20); + msg.mark := mark; msg.show := show; msg.type := type; msg.isSingle := isSingle; + msg.w := w; msg.h := h; msg.rx := rx; msg.ry := ry; msg.dest := NIL; + Transfer(x, y, source, sourceX, sourceY, msg); + dest := msg.dest; destX := msg.x; destY := msg.y + END PollDrop; + + PROCEDURE Drop* (x, y: INTEGER; source: Views.Frame; sourceX, sourceY: INTEGER; + view: Views.View; isSingle: BOOLEAN; w, h, rx, ry: INTEGER); + VAR msg: DropMsg; + BEGIN + ASSERT(source # NIL, 20); ASSERT(view # NIL, 21); + msg.view := view; msg.isSingle := isSingle; + msg.w := w; msg.h := h; msg.rx := rx; msg.ry := ry; + Transfer(x, y, source, sourceX, sourceY, msg) + END Drop; + + PROCEDURE PasteView* (view: Views.View; w, h: INTEGER; clipboard: BOOLEAN); + VAR msg: EditMsg; + BEGIN + ASSERT(view # NIL, 20); + msg.op := paste; msg.isSingle := TRUE; + msg.clipboard := clipboard; + msg.view := view; msg.w := w; msg.h := h; + Forward(msg) + END PasteView; + + + PROCEDURE FocusFrame* (): Views.Frame; + VAR msg: PollFocusMsg; + BEGIN + msg.focus := NIL; Forward(msg); RETURN msg.focus + END FocusFrame; + + PROCEDURE FocusView* (): Views.View; + VAR focus: Views.Frame; + BEGIN + focus := FocusFrame(); + IF focus # NIL THEN RETURN focus.view ELSE RETURN NIL END + END FocusView; + + PROCEDURE FocusModel* (): Models.Model; + VAR focus: Views.Frame; + BEGIN + focus := FocusFrame(); + IF focus # NIL THEN RETURN focus.view.ThisModel() ELSE RETURN NIL END + END FocusModel; + + + PROCEDURE HandleCtrlMsgs (op: INTEGER; f, g: Views.Frame; VAR msg: Message; VAR mark, front, req: BOOLEAN); + (* g = f.up OR g = NIL *) + CONST pre = 0; translate = 1; backoff = 2; final = 3; + BEGIN + CASE op OF + pre: + WITH msg: MarkMsg DO + IF msg.show & (g # NIL) THEN mark := TRUE; front := g.front END + | msg: RequestMessage DO + msg.requestFocus := FALSE + ELSE + END + | translate: + WITH msg: CursorMessage DO + msg.x := msg.x + f.gx - g.gx; + msg.y := msg.y + f.gy - g.gy + ELSE + END + | backoff: + WITH msg: MarkMsg DO + IF ~msg.show THEN mark := FALSE; front := FALSE END + | msg: RequestMessage DO + req := msg.requestFocus + ELSE + END + | final: + WITH msg: PollFocusMsg DO + IF msg.focus = NIL THEN msg.focus := f END + | msg: MarkMsg DO + IF ~msg.show THEN mark := FALSE; front := FALSE END + | msg: RequestMessage DO + req := msg.requestFocus + ELSE + END + END + END HandleCtrlMsgs; + + + PROCEDURE Init; + VAR action: BalanceCheckAction; w: WaitAction; + BEGIN + Views.InitCtrl(HandleCtrlMsgs); + NEW(cleaner); + NEW(action); NEW(w); action.wait := w; w.check := action; Services.DoLater(action, Services.immediately); + END Init; + +BEGIN + Init +END Controllers. diff --git a/Trurl-based/System/Mod/Controls.txt b/Trurl-based/System/Mod/Controls.txt new file mode 100644 index 0000000..6edecba --- /dev/null +++ b/Trurl-based/System/Mod/Controls.txt @@ -0,0 +1,3163 @@ +MODULE Controls; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Controls.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Dates, Dialog, Meta, Services, Stores, Views, Properties, + Strings, Fonts, Ports, Controllers, Windows, StdCFrames; + + CONST + (** elements of Property.valid **) + opt0* = 0; opt1* = 1; opt2* = 2; opt3* = 3; opt4* = 4; + link* = 5; label* = 6; guard* = 7; notifier* = 8; level* = 9; + + default* = opt0; cancel* = opt1; + left* = opt0; right* = opt1; multiLine* = opt2; password* = opt3; + sorted* = opt0; + haslines* = opt1; hasbuttons* = opt2; atroot* = opt3; foldericons* = opt4; + + minVersion = 0; maxBaseVersion = 4; + pbVersion = 0; cbVersion = 0; rbVersion = 0; fldVersion = 0; + dfldVersion = 0; tfldVersion = 0; cfldVersion = 0; + lbxVersion = 0; sbxVersion = 0; cbxVersion = 0; capVersion = 1; grpVersion = 0; + tfVersion = 0; + + rdel = 07X; ldel = 08X; tab = 09X; ltab = 0AX; lineChar = 0DX; esc = 01BX; + arrowLeft = 1CX; arrowRight = 1DX; arrowUp = 1EX; arrowDown = 1FX; + + update = 2; (* notify options *) + listUpdate = 3; + guardCheck = 4; + flushCaches = 5; (* re-map labels for flushed string resources, after a language change *) + + maxAdr = 8; + + TYPE + Prop* = POINTER TO RECORD (Properties.Property) + opt*: ARRAY 5 OF BOOLEAN; + link*: Dialog.String; + label*: Dialog.String; + guard*: Dialog.String; + notifier*: Dialog.String; + level*: INTEGER + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + Control* = POINTER TO ABSTRACT RECORD (Views.View) + item-: Meta.Item; + disabled-, undef-, readOnly-, customFont-: BOOLEAN; + font-: Fonts.Font; + label-: Dialog.String; + prop-: Prop; + adr: ARRAY maxAdr OF INTEGER; + num: INTEGER; + stamp: INTEGER; + shortcut: CHAR; + guardErr, notifyErr: BOOLEAN + END; + + DefaultsPref* = RECORD (Properties.Preference) + disabled*: BOOLEAN; (** OUT, preset to ~c.item.Valid() *) + undef*: BOOLEAN; (** OUT, preset to FALSE *) + readOnly*: BOOLEAN (** OUT, preset to c.item.vis = readOnly *) + END; + + PropPref* = RECORD (Properties.Preference) + valid*: SET (** OUT, preset to {link, label, guard, notifier, customFont} *) + END; + + PushButton = POINTER TO RECORD (Control) END; + + CheckBox = POINTER TO RECORD (Control) END; + + RadioButton = POINTER TO RECORD (Control) END; + + Field = POINTER TO RECORD (Control) + maxLen: INTEGER + END; + + UpDownField = POINTER TO RECORD (Control) + min, max, inc: INTEGER + END; + + DateField = POINTER TO RECORD (Control) + selection: INTEGER (* 0: no selection, 1..n-1: this part selected, -1: part n selected *) + END; + + TimeField = POINTER TO RECORD (Control) + selection: INTEGER + END; + + ColorField = POINTER TO RECORD (Control) END; + + ListBox = POINTER TO RECORD (Control) END; + + SelectionBox = POINTER TO RECORD (Control) END; + + ComboBox = POINTER TO RECORD (Control) END; + + Caption = POINTER TO RECORD (Control) END; + + Group = POINTER TO RECORD (Control) END; + + TreeControl = POINTER TO RECORD (Control) END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + Op = POINTER TO RECORD (Stores.Operation) + ctrl: Control; + prop: Prop + END; + + FontOp = POINTER TO RECORD (Stores.Operation) + ctrl: Control; + font: Fonts.Font; + custom: BOOLEAN + END; + + NotifyMsg = RECORD (Views.NotifyMsg) + frame: Views.Frame; + op, from, to: INTEGER + END; + + UpdateCachesMsg = RECORD (Views.UpdateCachesMsg) END; + + SelectPtr = POINTER TO Dialog.Selection; + + ProcValue = RECORD (Meta.Value) p*: PROCEDURE END; + SelectValue = RECORD (Meta.Value) p*: SelectPtr END; + GuardProcVal = RECORD (Meta.Value) p*: Dialog.GuardProc END; + NotifyProcValOld = RECORD (Meta.Value) p*: PROCEDURE (op, from, to: INTEGER) END; + GuardProcPVal = RECORD (Meta.Value) p*: PROCEDURE(n: INTEGER; VAR p: Dialog.Par) END; + NotifyProcPVal = RECORD (Meta.Value) p*: PROCEDURE(n, op, f, t: INTEGER) END; + + Param = RECORD from, to, i: INTEGER; n: Dialog.String END; + + TVParam = RECORD l: INTEGER; e: BOOLEAN; nodeIn, nodeOut: Dialog.TreeNode END; + + Action = POINTER TO RECORD (Services.Action) + w: Windows.Window; + resolution, cnt: INTEGER + END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + + VAR + dir-, stdDir-: Directory; + par-: Control; + stamp: INTEGER; + action: Action; + cleaner: TrapCleaner; + cleanerInstalled: INTEGER; + + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + par := NIL; + cleanerInstalled := 0 + END Cleanup; + + + PROCEDURE (c: Control) Update- (f: Views.Frame; op, from, to: INTEGER), NEW, EMPTY; + PROCEDURE (c: Control) UpdateList- (f: Views.Frame), NEW, EMPTY; + PROCEDURE (c: Control) CheckLink- (VAR ok: BOOLEAN), NEW, EMPTY; + PROCEDURE (c: Control) HandlePropMsg2- (VAR p: Views.PropMessage), NEW, EMPTY; + PROCEDURE (c: Control) HandleViewMsg2- (f: Views.Frame; VAR msg: Views.Message), NEW, EMPTY; + PROCEDURE (c: Control) HandleCtrlMsg2- (f: Views.Frame; VAR msg: Views.CtrlMessage; + VAR focus: Views.View), NEW, EMPTY; + PROCEDURE (c: Control) Externalize2- (VAR wr: Stores.Writer), NEW, EMPTY; + PROCEDURE (c: Control) Internalize2- (VAR rd: Stores.Reader), NEW, EMPTY; + + + (* auxiliary procedures *) + + PROCEDURE IsShortcut (ch: CHAR; c: Control): BOOLEAN; + BEGIN + IF (ch >= "a") & (ch <= "z") OR (ch >= 0E0X) THEN ch := CAP(ch) END; + RETURN ch = c.shortcut + END IsShortcut; + + PROCEDURE ExtractShortcut (c: Control); + VAR label: Dialog.String; i: INTEGER; ch, sCh: CHAR; + BEGIN + Dialog.MapString(c.label, label); + i := 0; ch := label[0]; sCh := "&"; + WHILE sCh = "&" DO + WHILE (ch # 0X) & (ch # "&") DO INC(i); ch := label[i] END; + IF ch = 0X THEN sCh := 0X + ELSE INC(i); sCh := label[i]; INC(i); ch := label[i] + END + END; + IF (sCh >= "a") & (sCh <= "z") OR (sCh >= 0E0X) THEN sCh := CAP(sCh) END; + c.shortcut := sCh + END ExtractShortcut; + + PROCEDURE GetGuardProc (name: ARRAY OF CHAR; VAR i: Meta.Item; VAR err: BOOLEAN; + VAR par: BOOLEAN; VAR n: INTEGER); + VAR j, k, e: INTEGER; num: ARRAY 32 OF CHAR; + BEGIN + j := 0; + WHILE (name[j] # 0X) & (name[j] # "(") DO INC(j) END; + IF name[j] = "(" THEN + 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, e); + IF e = 0 THEN + name[j - k - 1] := 0X; + Meta.LookupPath(name, i); par := TRUE + ELSE + IF ~err THEN + Dialog.ShowParamMsg("#System:SyntaxErrorIn", name, "", ""); + err := TRUE + END; + Meta.Lookup("", i); + RETURN + END + ELSE + IF ~err THEN + Dialog.ShowParamMsg("#System:SyntaxErrorIn", name, "", ""); + err := TRUE + END; + Meta.Lookup("", i); + RETURN + END + ELSE + Meta.LookupPath(name, i); par := FALSE + END; + IF (i.obj = Meta.procObj) OR (i.obj = Meta.varObj) & (i.typ = Meta.procTyp) THEN (*ok *) + ELSE + IF ~err THEN + IF i.obj = Meta.undef THEN + Dialog.ShowParamMsg("#System:NotFound", name, "", "") + ELSE + Dialog.ShowParamMsg("#System:HasWrongType", name, "", "") + END; + err := TRUE + END; + Meta.Lookup("", i) + END + END GetGuardProc; + + PROCEDURE CallGuard (c: Control); + VAR ok, up: BOOLEAN; n: INTEGER; dpar: Dialog.Par; p: Control; + v: GuardProcVal; vp: GuardProcPVal; i: Meta.Item; pref: DefaultsPref; + BEGIN + Controllers.SetCurrentPath(Controllers.targetPath); + pref.disabled := ~c.item.Valid(); + pref.undef := FALSE; + pref.readOnly := c.item.vis = Meta.readOnly; + Views.HandlePropMsg(c, pref); + c.disabled := pref.disabled; + c.undef := pref.undef; + c.readOnly := pref.readOnly; + c.label := c.prop.label$; + IF ~c.disabled & (c.prop.guard # "") & ~c.guardErr THEN + IF cleanerInstalled = 0 THEN Kernel.PushTrapCleaner(cleaner) END; + INC(cleanerInstalled); + p := par; par := c; + dpar.disabled := FALSE; dpar.undef := FALSE; + dpar.readOnly := c.readOnly; + dpar.checked := FALSE; dpar.label := c.label$; + GetGuardProc(c.prop.guard, i, c.guardErr, up, n); + IF i.obj # Meta.undef THEN + IF up THEN (* call with numeric parameter *) + i.GetVal(vp, ok); + IF ok THEN vp.p(n, dpar) END + ELSE + i.GetVal(v, ok); + IF ok THEN v.p(dpar) END + END; + IF ok THEN + c.disabled := dpar.disabled; + c.undef := dpar.undef; + IF dpar.readOnly THEN c.readOnly := TRUE END; + IF dpar.label # c.label THEN c.label := dpar.label END + ELSIF ~c.guardErr THEN + Dialog.ShowParamMsg("#System:HasWrongType", c.prop.guard, "", ""); + c.guardErr := TRUE + END + END; + par := p; + DEC(cleanerInstalled); + IF cleanerInstalled = 0 THEN Kernel.PopTrapCleaner(cleaner) END + END; + ExtractShortcut(c); + Controllers.ResetCurrentPath() + END CallGuard; + + PROCEDURE CallNotifier (c: Control; op, from, to: INTEGER); + VAR ok, up: BOOLEAN; n: INTEGER; vold: NotifyProcValOld; vp: NotifyProcPVal; + i: Meta.Item; p: Control; + BEGIN + IF c.prop.notifier # "" THEN + IF cleanerInstalled = 0 THEN Kernel.PushTrapCleaner(cleaner) END; + INC(cleanerInstalled); + p := par; par := c; + IF c.prop.notifier[0] = "!" THEN + IF op = Dialog.pressed THEN + c.prop.notifier[0] := " "; + Dialog.ShowStatus(c.prop.notifier); + c.prop.notifier[0] := "!" + ELSIF op = Dialog.released THEN + Dialog.ShowStatus("") + END + ELSE + GetGuardProc(c.prop.notifier, i, c.notifyErr, up, n); + IF i.obj # Meta.undef THEN + IF up THEN (* call with numeric parameter *) + i.GetVal(vp, ok); + IF ok THEN vp.p(n, op, from, to) END + ELSE + i.GetVal(vold, ok); + IF ok THEN vold.p(op, from, to) END + END; + IF ~ok & ~c.notifyErr THEN + Dialog.ShowParamMsg("#System:HasWrongType", c.prop.notifier, "", ""); + c.notifyErr := TRUE + END + END + END; + par := p; + DEC(cleanerInstalled); + IF cleanerInstalled = 0 THEN Kernel.PopTrapCleaner(cleaner) END + END + END CallNotifier; + + PROCEDURE DCHint (modifiers: SET): INTEGER; + BEGIN + IF Controllers.doubleClick IN modifiers THEN RETURN 1 + ELSE RETURN 0 + END + END DCHint; + + PROCEDURE Notify* (c: Control; f: Views.Frame; op, from, to: INTEGER); + VAR msg: NotifyMsg; + BEGIN + IF ~c.readOnly & ~ c.disabled THEN + CallNotifier(c, op, from, to); + IF op >= Dialog.changed THEN + msg.id0 := c.item.adr; msg.id1 := msg.id0 + c.item.Size(); msg.frame := f; + msg.op := op; msg.from := from; msg.to := to; + msg.opts := {update, guardCheck}; + Views.Omnicast(msg) + END + END + END Notify; + + PROCEDURE NotifyFlushCaches*; + VAR msg: NotifyMsg; + BEGIN + msg.opts := {flushCaches}; msg.id0 := 0; msg.id1 := 0; + Views.Omnicast(msg) + END NotifyFlushCaches; + + PROCEDURE GetName (VAR path, name: ARRAY OF CHAR; VAR i: INTEGER); + VAR j: INTEGER; ch: CHAR; + BEGIN + j := 0; ch := path[i]; + WHILE (j < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z") + OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO + name[j] := ch; INC(i); INC(j); ch := path[i] + END; + IF (ch = 0X) OR (ch = ".") OR (ch = "[") OR (ch = "^") THEN name[j] := 0X + ELSE name[0] := 0X + END + END GetName; + + PROCEDURE LookupPath (path: ARRAY OF CHAR; VAR i: Meta.Item; + VAR adr: ARRAY OF INTEGER; VAR num: INTEGER); + VAR j, n: INTEGER; name: Meta.Name; ch: CHAR; + BEGIN + path[LEN(path) - 1] := 0X; j := 0; num := 0; + GetName(path, name, j); Meta.Lookup(name, i); + IF (i.obj = Meta.modObj) & (path[j] = ".") THEN + INC(j); GetName(path, name, j); + i.Lookup(name, i); ch := path[j]; INC(j); + WHILE i.obj = Meta.varObj DO + adr[num] := i.adr; + IF num < LEN(adr) - 1 THEN INC(num) END; + IF ch = 0X THEN RETURN + ELSIF i.typ = Meta.ptrTyp THEN + IF ch = "^" THEN ch := path[j]; INC(j) END; + i.Deref(i) + ELSIF (i.typ = Meta.recTyp) & (ch = ".") THEN + GetName(path, name, j); i.Lookup(name, i); + ch := path[j]; INC(j) + ELSIF (i.typ = Meta.arrTyp) & (ch = "[") THEN + ch := path[j]; INC(j); n := 0; + WHILE (ch >= "0") & (ch <= "9") DO n := 10 * n + ORD(ch) - ORD("0"); ch := path[j]; INC(j) END; + IF ch = "]" THEN ch := path[j]; INC(j); i.Index(n, i) ELSE Meta.Lookup("", i) END + ELSE Meta.Lookup("", i) + END + END + ELSE + Meta.LookupPath(path, i); num := 0; + IF i.obj = Meta.varObj THEN adr[0] := i.adr; num := 1 + ELSIF i.obj # Meta.procObj THEN Meta.Lookup("", i) + END + END + END LookupPath; + + PROCEDURE Sort (VAR adr: ARRAY OF INTEGER; num: INTEGER); + VAR i, j, p: INTEGER; + BEGIN + i := 1; + WHILE i < num DO + p := adr[i]; j := i; + WHILE (j >= 1) & (adr[j - 1] > p) DO adr[j] := adr[j - 1]; DEC(j) END; + adr[j] := p; INC(i) + END + END Sort; + + PROCEDURE GetTypeName (IN item: Meta.Item; OUT name: Meta.Name); + VAR mod: Meta.Name; + BEGIN + IF (item.typ = Meta.recTyp) THEN + item.GetTypeName(mod, name); + IF (mod = "Dialog") OR (mod = "Dates") THEN (* ok *) + ELSE name := "" + END + ELSE name := "" + END + END GetTypeName; + + PROCEDURE OpenLink* (c: Control; p: Prop); + VAR ok: BOOLEAN; + BEGIN + ASSERT(c # NIL, 20); ASSERT(p # NIL, 21); + c.num := 0; + c.prop := Properties.CopyOf(p)(Prop); + IF c.font = NIL THEN + IF c.customFont THEN c.font := StdCFrames.defaultLightFont + ELSE c.font := StdCFrames.defaultFont + END + END; + c.guardErr := FALSE; c.notifyErr := FALSE; + LookupPath(p.link, c.item, c.adr, c.num); + IF c.item.obj = Meta.varObj THEN + Sort(c.adr, c.num); + ok := TRUE; c.CheckLink(ok); + IF ~ok THEN + Meta.Lookup("", c.item); + Dialog.ShowParamMsg("#System:HasWrongType", p.link, "", "") + END + ELSE + Meta.Lookup("", c.item); c.num := 0 + END; + CallGuard(c); + c.stamp := stamp + END OpenLink; + + + (** Prop **) + + 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.link # q.link THEN EXCL(valid, link) END; + IF p.label # q.label THEN EXCL(valid, label) END; + IF p.guard # q.guard THEN EXCL(valid, guard) END; + IF p.notifier # q.notifier THEN EXCL(valid, notifier) END; + IF p.level # q.level THEN EXCL(valid, level) END; + IF p.opt[0] # q.opt[0] THEN EXCL(valid, opt0) END; + IF p.opt[1] # q.opt[1] THEN EXCL(valid, opt1) END; + IF p.opt[2] # q.opt[2] THEN EXCL(valid, opt2) END; + IF p.opt[3] # q.opt[3] THEN EXCL(valid, opt3) END; + IF p.opt[4] # q.opt[4] THEN EXCL(valid, opt4) END; + IF p.valid # valid THEN p.valid := valid; equal := FALSE END + END + END IntersectWith; + + + (* Control *) + + PROCEDURE (c: Control) CopyFromSimpleView2- (source: Control), NEW, EMPTY; + + PROCEDURE (c: Control) CopyFromSimpleView- (source: Views.View); + BEGIN + WITH source: Control DO + c.item := source.item; + c.adr := source.adr; + c.num := source.num; + c.disabled := source.disabled; + c.undef := source.undef; + c.readOnly := source.readOnly; + c.shortcut := source.shortcut; + c.customFont := source.customFont; + c.font := source.font; + c.label := source.label$; + c.prop := Properties.CopyOf(source.prop)(Prop); + c.CopyFromSimpleView2(source) + END + END CopyFromSimpleView; + + PROCEDURE (c: Control) Internalize- (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; x, def, canc, sort: BOOLEAN; + BEGIN + c.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxBaseVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + NEW(c.prop); + IF thisVersion >= 3 THEN + rd.ReadString(c.prop.link); + rd.ReadString(c.prop.label); + rd.ReadString(c.prop.guard); + rd.ReadString(c.prop.notifier); + rd.ReadInt(c.prop.level); + rd.ReadBool(c.customFont); + rd.ReadBool(c.prop.opt[0]); + rd.ReadBool(c.prop.opt[1]); + rd.ReadBool(c.prop.opt[2]); + rd.ReadBool(c.prop.opt[3]); + rd.ReadBool(c.prop.opt[4]); + IF c.customFont & (thisVersion = 4) THEN + Views.ReadFont(rd, c.font) + END + ELSE + rd.ReadXString(c.prop.link); + rd.ReadXString(c.prop.label); + rd.ReadXString(c.prop.guard); + c.prop.notifier := ""; + c.prop.opt[2] := FALSE; + c.prop.opt[3] := FALSE; + c.prop.opt[4] := FALSE; + sort := FALSE; + IF thisVersion = 2 THEN + rd.ReadXString(c.prop.notifier); + rd.ReadBool(sort); + rd.ReadBool(c.prop.opt[multiLine]) + ELSIF thisVersion = 1 THEN + rd.ReadXString(c.prop.notifier); + rd.ReadBool(sort) + END; + rd.ReadBool(x); (* free, was sed for prop.element *) + rd.ReadBool(def); + rd.ReadBool(canc); + rd.ReadXInt(c.prop.level); + rd.ReadBool(c.customFont); + c.prop.opt[default] := def OR sort OR (c IS Field); + c.prop.opt[cancel] := canc + END; + c.Internalize2(rd); + OpenLink(c, c.prop) + END Internalize; + + PROCEDURE (c: Control) Externalize- (VAR wr: Stores.Writer); + BEGIN + c.Externalize^(wr); + wr.WriteVersion(maxBaseVersion); + wr.WriteString(c.prop.link); + wr.WriteString(c.prop.label); + wr.WriteString(c.prop.guard); + wr.WriteString(c.prop.notifier); + wr.WriteInt(c.prop.level); + wr.WriteBool(c.customFont); + wr.WriteBool(c.prop.opt[0]); + wr.WriteBool(c.prop.opt[1]); + wr.WriteBool(c.prop.opt[2]); + wr.WriteBool(c.prop.opt[3]); + wr.WriteBool(c.prop.opt[4]); + IF c.customFont THEN Views.WriteFont(wr, c.font) END; + c.Externalize2(wr) + END Externalize; + + PROCEDURE (c: Control) HandleViewMsg- (f: Views.Frame; VAR msg: Views.Message); + VAR disabled, undef, readOnly, done, allDone: BOOLEAN; i: INTEGER; lbl: Dialog.String; + BEGIN + WITH msg: Views.NotifyMsg DO + done := FALSE; allDone := FALSE; + IF guardCheck IN msg.opts THEN + (* should call c.Update for each frame but Views.Update only once *) + WITH f: StdCFrames.Caption DO lbl := f.label$ + | f: StdCFrames.PushButton DO lbl := f.label$ + | f: StdCFrames.RadioButton DO lbl := f.label$ + | f: StdCFrames.CheckBox DO lbl := f.label$ + | f: StdCFrames.Group DO lbl := f.label$ + ELSE lbl := c.label$ + END; + WITH f: StdCFrames.Frame DO + disabled := f.disabled; undef := f.undef; readOnly := f.readOnly + ELSE + disabled := c.disabled; undef := c.undef; readOnly := c.readOnly + END; + CallGuard(c); + IF (c.disabled # disabled) OR (c.undef # undef) + OR (c.readOnly # readOnly) OR (c.label # lbl) THEN + WITH f: StdCFrames.Frame DO + IF f.noRedraw THEN + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + c.Update(f, 0, 0, 0); done := TRUE + ELSE Views.Update(c, Views.rebuildFrames); allDone := TRUE + END + ELSE Views.Update(c, Views.keepFrames); done := TRUE + END + END + END; + IF flushCaches IN msg.opts THEN + Views.Update(c, Views.rebuildFrames) + END; + i := 0; WHILE (i < c.num) & (c.adr[i] < msg.id0) DO INC(i) END; + IF (i < c.num) & (c.adr[i] < msg.id1) & ~allDone THEN + IF (update IN msg.opts) & ~done THEN + WITH msg: NotifyMsg DO + IF msg.frame # f THEN (* don't update origin frame *) + c.Update(f, msg.op, msg.from, msg.to) + END + ELSE + c.Update(f, 0, 0, 0) + END + END; + IF listUpdate IN msg.opts THEN + c.UpdateList(f) + END + END + | msg: Views.UpdateCachesMsg DO + IF c.stamp # stamp THEN + OpenLink(c, c.prop); + IF msg IS UpdateCachesMsg THEN + Views.Update(c, Views.rebuildFrames) + END + END + ELSE + END; + c.HandleViewMsg2(f, msg) + END HandleViewMsg; + + PROCEDURE (c: Control) HandleCtrlMsg* (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + VAR sp: Properties.SizeProp; p: Control; dcOk: BOOLEAN; + BEGIN + IF cleanerInstalled = 0 THEN Kernel.PushTrapCleaner(cleaner) END; + INC(cleanerInstalled); + p := par; par := c; + WITH msg: Properties.PollPickMsg DO + msg.dest := f + | msg: Properties.PickMsg DO + NEW(sp); sp.known := {Properties.width, Properties.height}; sp.valid := sp.known; + c.context.GetSize(sp.width, sp.height); + Properties.Insert(msg.prop, sp) + | msg: Controllers.TrackMsg DO + IF ~c.disabled THEN + dcOk := TRUE; + IF f IS StdCFrames.Frame THEN dcOk := f(StdCFrames.Frame).DblClickOk(msg.x, msg.y) END; + IF (DCHint(msg.modifiers) = 1) & dcOk THEN + (* double click *) + Notify(c, f, Dialog.pressed, 1, 0) + ELSE + Notify(c, f, Dialog.pressed, 0, 0) + END + END + ELSE + END; + c.HandleCtrlMsg2(f, msg, focus); + WITH msg: Controllers.TrackMsg DO + IF ~c.disabled THEN + Notify(c, f, Dialog.released, 0, 0) + END + ELSE + END; + par := p; + DEC(cleanerInstalled); + IF cleanerInstalled = 0 THEN Kernel.PopTrapCleaner(cleaner) END + END HandleCtrlMsg; + + PROCEDURE (c: Control) HandlePropMsg- (VAR msg: Properties.Message); + VAR fpref: Properties.FocusPref; stp: Properties.StdProp; + cp: Prop; ppref: PropPref; op: Op; valid: SET; p: Properties.Property; + fop: FontOp; face: Fonts.Typeface; size, weight: INTEGER; style: SET; + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN + fpref.hotFocus := FALSE; fpref.setFocus := FALSE; fpref.atLocation := FALSE; + Views.HandlePropMsg(c, fpref); + IF fpref.setFocus THEN msg.getFocus := TRUE END + END + | msg: Properties.PollMsg DO + ppref.valid := {link, label, notifier, guard}; + Views.HandlePropMsg(c, ppref); + cp := Properties.CopyOf(c.prop)(Prop); + cp.valid := ppref.valid; cp.known := cp.valid; cp.readOnly := {}; + Properties.Insert(msg.prop, cp); + NEW(stp); + stp.valid := {Properties.typeface..Properties.weight}; + stp.known := stp.valid; + IF c.customFont THEN stp.typeface := c.font.typeface$ + ELSE stp.typeface := Fonts.default + END; + stp.size := c.font.size; stp.style.val := c.font.style; stp.weight := c.font.weight; + stp.style.mask := {Fonts.italic, Fonts.strikeout, Fonts.underline}; + Properties.Insert(msg.prop, stp) + | msg: Properties.SetMsg DO + p := msg.prop; op := NIL; fop := NIL; + WHILE (p # NIL) & (op = NIL) DO + WITH p: Prop DO + ppref.valid := {link, label, notifier, guard}; + Views.HandlePropMsg(c, ppref); + valid := p.valid * ppref.valid; + IF valid # {} THEN + NEW(op); + op.ctrl := c; + op.prop := Properties.CopyOf(p)(Prop); op.prop.valid := valid + END + | p: Properties.StdProp DO + valid := p.valid * {Properties.typeface..Properties.weight}; + IF valid # {} THEN + NEW(fop); fop.ctrl := c; + face := c.font.typeface$; size := c.font.size; style := c.font.style; weight := c.font.weight; + IF Properties.typeface IN p.valid THEN face := p.typeface$; + IF face = Fonts.default THEN face := StdCFrames.defaultFont.typeface END + END; + IF Properties.size IN p.valid THEN size := p.size END; + IF Properties.style IN p.valid THEN + style := (p.style.val * p.style.mask) + (style - p.style.mask) + END; + IF Properties.weight IN p.valid THEN weight := p.weight END; + fop.custom := TRUE; + fop.font := Fonts.dir.This(face, size, style, weight); + IF (fop.font.typeface = StdCFrames.defaultFont.typeface) + & (fop.font.size = StdCFrames.defaultFont.size) + & (fop.font.style = StdCFrames.defaultFont.style) + & (fop.font.weight = StdCFrames.defaultFont.weight) THEN + fop.custom := FALSE; + fop.font := StdCFrames.defaultFont + END + END + ELSE + END; + p := p.next + END; + IF op # NIL THEN Views.Do(c, "#System:SetProp", op) END; + IF fop # NIL THEN Views.Do(c, "#System:SetProp", fop) END + | msg: Properties.TypePref DO + IF Services.Is(c, msg.type) THEN msg.view := c END + ELSE + END; + c.HandlePropMsg2(msg) + END HandlePropMsg; + + + (* Op *) + + PROCEDURE (op: Op) Do; + VAR c: Control; prop: Prop; + BEGIN + c := op.ctrl; + prop := Properties.CopyOf(c.prop)(Prop); + prop.valid := op.prop.valid; (* fields to be restored *) + IF link IN op.prop.valid THEN c.prop.link := op.prop.link END; + IF label IN op.prop.valid THEN c.prop.label := op.prop.label END; + IF guard IN op.prop.valid THEN c.prop.guard := op.prop.guard END; + IF notifier IN op.prop.valid THEN c.prop.notifier := op.prop.notifier END; + IF level IN op.prop.valid THEN c.prop.level := op.prop.level END; + IF opt0 IN op.prop.valid THEN c.prop.opt[0] := op.prop.opt[0] END; + IF opt1 IN op.prop.valid THEN c.prop.opt[1] := op.prop.opt[1] END; + IF opt2 IN op.prop.valid THEN c.prop.opt[2] := op.prop.opt[2] END; + IF opt3 IN op.prop.valid THEN c.prop.opt[3] := op.prop.opt[3] END; + IF opt4 IN op.prop.valid THEN c.prop.opt[4] := op.prop.opt[4] END; + IF c.prop.guard # prop.guard THEN c.guardErr := FALSE END; + IF c.prop.notifier # prop.notifier THEN c.notifyErr := FALSE END; + IF c.prop.link # prop.link THEN OpenLink(c, c.prop) ELSE CallGuard(c) END; + op.prop := prop; + Views.Update(c, Views.rebuildFrames) + END Do; + + PROCEDURE (op: FontOp) Do; + VAR c: Control; custom: BOOLEAN; font: Fonts.Font; + BEGIN + c := op.ctrl; + custom := c.customFont; c.customFont := op.custom; op.custom := custom; + font := c.font; c.font := op.font; op.font := font; + Views.Update(c, Views.rebuildFrames) + END Do; + + + (* ------------------------- standard controls ------------------------- *) + + PROCEDURE CatchCtrlMsg (c: Control; f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled THEN + WITH f: StdCFrames.Frame DO + WITH msg: Controllers.PollCursorMsg DO + f.GetCursor(msg.x, msg.y, msg.modifiers, msg.cursor) + | msg: Controllers.PollOpsMsg DO + msg.valid := {Controllers.pasteChar} + | msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + | msg: Controllers.MarkMsg DO + f.Mark(msg.show, msg.focus) + |msg: Controllers.WheelMsg DO + f.WheelMove(msg.x, msg.y, msg.op, msg.nofLines, msg.done) + ELSE + END + END + END + END CatchCtrlMsg; + + + (** Directory **) + + PROCEDURE (d: Directory) NewPushButton* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewCheckBox* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewRadioButton* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewField* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewUpDownField* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewDateField* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewTimeField* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewColorField* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewListBox* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewSelectionBox* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewComboBox* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewCaption* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewGroup* (p: Prop): Control, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewTreeControl* (p: Prop): Control, NEW, ABSTRACT; + + + (* PushButton *) + + PROCEDURE Call (c: PushButton); + VAR res: INTEGER; p: Control; ok: BOOLEAN; msg: Views.NotifyMsg; + BEGIN + IF c.item.Valid() & ((c.item.obj = Meta.procObj) OR (c.item.obj = Meta.varObj) & (c.item.typ = Meta.procTyp)) THEN + IF cleanerInstalled = 0 THEN Kernel.PushTrapCleaner(cleaner) END; + INC(cleanerInstalled); + p := par; c.item.Call(ok); par := p; + DEC(cleanerInstalled); + IF cleanerInstalled = 0 THEN Kernel.PopTrapCleaner(cleaner) END; + IF ~ok THEN Dialog.ShowMsg("#System:BehaviorNotAccessible") END + ELSIF c.prop.link # "" THEN + IF cleanerInstalled = 0 THEN Kernel.PushTrapCleaner(cleaner) END; + INC(cleanerInstalled); + p := par; par := c; Dialog.Call(c.prop.link, " ", res); par := p; + DEC(cleanerInstalled); + IF cleanerInstalled = 0 THEN Kernel.PopTrapCleaner(cleaner) END + ELSE Dialog.ShowMsg("#System:NoBehaviorBound") + END; + msg.opts := {guardCheck}; + Views.Omnicast(msg) + END Call; + + PROCEDURE Do (f: StdCFrames.PushButton); + BEGIN + Call(f.view(PushButton)) + END Do; + + PROCEDURE (c: PushButton) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, pbVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: PushButton) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(pbVersion) + END Externalize2; + + PROCEDURE (c: PushButton) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.PushButton; + BEGIN + f := StdCFrames.dir.NewPushButton(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.label := c.label$; + f.default := c.prop.opt[default]; + f.cancel := c.prop.opt[cancel]; + f.Do := Do; + frame := f + END GetNewFrame; + + PROCEDURE (c: PushButton) 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 (c: PushButton) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled THEN + WITH f: StdCFrames.Frame DO + WITH msg: Controllers.EditMsg DO + IF (msg.op = Controllers.pasteChar) + & ((msg.char = lineChar) + OR (msg.char = " ") + OR (msg.char = esc) & c.prop.opt[cancel] + OR IsShortcut(msg.char, c)) THEN f.KeyDown(msg.char) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: PushButton) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + msg.accepts := ~c.disabled & ((msg.char = lineChar) & c.prop.opt[default] + OR (msg.char = esc) & c.prop.opt[cancel] + OR IsShortcut(msg.char, c)) + | msg: Properties.FocusPref DO + IF ~c.disabled & ~ c.readOnly THEN + msg.hotFocus := TRUE; msg.setFocus := StdCFrames.setFocus + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetPushButtonSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, default, cancel} + | msg: DefaultsPref DO + IF c.prop.link # "" THEN msg.disabled := FALSE END + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: PushButton) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.PushButton).label := c.label$; + f(StdCFrames.Frame).Update + END Update; + + PROCEDURE (c: PushButton) CheckLink (VAR ok: BOOLEAN); + BEGIN + ok := c.item.typ = Meta.procTyp + END CheckLink; + + + (* CheckBox *) + + PROCEDURE GetCheckBox (f: StdCFrames.CheckBox; OUT x: BOOLEAN); + VAR c: CheckBox; + BEGIN + x := FALSE; + c := f.view(CheckBox); + IF c.item.Valid() THEN + IF c.item.typ = Meta.boolTyp THEN x := c.item.BoolVal() + ELSIF c.item.typ = Meta.setTyp THEN x := c.prop.level IN c.item.SetVal() + END + END + END GetCheckBox; + + PROCEDURE SetCheckBox (f: StdCFrames.CheckBox; x: BOOLEAN); + VAR c: CheckBox; s: SET; + BEGIN + c := f.view(CheckBox); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.typ = Meta.boolTyp THEN + c.item.PutBoolVal(x); Notify(c, f, Dialog.changed, 0, 0) + ELSIF c.item.typ = Meta.setTyp THEN + s := c.item.SetVal(); + IF x THEN INCL(s, c.prop.level) ELSE EXCL(s, c.prop.level) END; + c.item.PutSetVal(s); + IF x THEN Notify(c, f, Dialog.included, c.prop.level, c.prop.level) + ELSE Notify(c, f, Dialog.excluded, c.prop.level, c.prop.level) + END + END + END + END SetCheckBox; + + PROCEDURE (c: CheckBox) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, cbVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: CheckBox) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(cbVersion) + END Externalize2; + + PROCEDURE (c: CheckBox) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.CheckBox; + BEGIN + f := StdCFrames.dir.NewCheckBox(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.label := c.label$; + f.Get := GetCheckBox; + f.Set := SetCheckBox; + frame := f + END GetNewFrame; + + PROCEDURE (c: CheckBox) 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 (c: CheckBox) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.Frame DO + WITH msg: Controllers.EditMsg DO + IF (msg.op = Controllers.pasteChar) + & ((msg.char = " ") OR IsShortcut(msg.char, c)) THEN f.KeyDown(msg.char) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: CheckBox) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF ~c.disabled & ~c.readOnly THEN + IF (msg.char = tab) OR (msg.char = ltab) THEN + (* tabs set focus to first checkbox only *) + IF (msg.focus # NIL) & (msg.focus IS CheckBox) + & (msg.focus(CheckBox).item.adr = c.item.adr) THEN + msg.getFocus := FALSE + END + ELSIF (msg.char >= arrowLeft) & (msg.char <= arrowDown) THEN + (* arrows set focus to next checkbox bound to same variable *) + msg.getFocus := StdCFrames.setFocus + & (msg.focus # NIL) + & (msg.focus IS CheckBox) + & (msg.focus(CheckBox).item.adr = c.item.adr); + msg.accepts := msg.getFocus & (msg.focus # c) + ELSIF IsShortcut(msg.char, c) THEN + msg.accepts := TRUE; msg.getFocus := StdCFrames.setFocus + ELSIF msg.char # " " THEN + msg.accepts := FALSE + END + END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.hotFocus := TRUE; msg.setFocus := StdCFrames.setFocus + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetCheckBoxSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, level} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: CheckBox) CheckLink (VAR ok: BOOLEAN); + BEGIN + ok := (c.item.typ = Meta.boolTyp) OR (c.item.typ = Meta.setTyp) + END CheckLink; + + PROCEDURE (c: CheckBox) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + IF (op = 0) OR (c.item.typ = Meta.boolTyp) OR (c.prop.level = to) THEN + f(StdCFrames.CheckBox).label := c.label$; + f(StdCFrames.Frame).Update + END + END Update; + + + (* RadioButton *) + + PROCEDURE GetRadioButton (f: StdCFrames.RadioButton; OUT x: BOOLEAN); + VAR c: RadioButton; + BEGIN + x := FALSE; + c := f.view(RadioButton); + IF c.item.Valid() THEN + IF c.item.typ = Meta.boolTyp THEN x := c.item.BoolVal() = (c.prop.level # 0) + ELSE x := c.item.IntVal() = c.prop.level + END + END + END GetRadioButton; + + PROCEDURE SetRadioButton (f: StdCFrames.RadioButton; x: BOOLEAN); + VAR c: RadioButton; old: INTEGER; + BEGIN + IF x THEN + c := f.view(RadioButton); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.typ = Meta.boolTyp THEN + IF c.item.BoolVal() THEN old := 1 ELSE old := 0 END; + IF c.prop.level # old THEN + c.item.PutBoolVal(c.prop.level # 0); + Notify(c, f, Dialog.changed, old, c.prop.level) + END + ELSE + old := c.item.IntVal(); + IF c.prop.level # old THEN + c.item.PutIntVal(c.prop.level); + Notify(c, f, Dialog.changed, old, c.prop.level) + END + END + END + END + END SetRadioButton; + + PROCEDURE (c: RadioButton) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, rbVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: RadioButton) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(rbVersion) + END Externalize2; + + PROCEDURE (c: RadioButton) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.RadioButton; + BEGIN + f := StdCFrames.dir.NewRadioButton(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.label := c.label$; + f.Get := GetRadioButton; + f.Set := SetRadioButton; + frame := f + END GetNewFrame; + + PROCEDURE (c: RadioButton) 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 (c: RadioButton) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.Frame DO + WITH msg: Controllers.EditMsg DO + IF (msg.op = Controllers.pasteChar) + & ((msg.char <= " ") OR IsShortcut(msg.char, c)) THEN f.KeyDown(msg.char) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: RadioButton) HandlePropMsg2 (VAR msg: Properties.Message); + VAR hot: BOOLEAN; + BEGIN + WITH msg: Properties.ControlPref DO + IF ~c.disabled & ~c.readOnly THEN + IF (msg.char = tab) OR (msg.char = ltab) THEN + (* tabs set focus to active radio button only *) + IF c.item.Valid() THEN + IF c.item.typ = Meta.boolTyp THEN hot := c.item.BoolVal() = (c.prop.level # 0) + ELSE hot := c.item.IntVal() = c.prop.level + END + ELSE hot := FALSE + END; + IF ~hot THEN msg.getFocus := FALSE END + ELSIF (msg.char >= arrowLeft) & (msg.char <= arrowDown) THEN + (* arrows set focus to next radio button bound to same variable *) + msg.getFocus := StdCFrames.setFocus + & (msg.focus # NIL) & (msg.focus IS RadioButton) + & (msg.focus(RadioButton).item.adr = c.item.adr); + msg.accepts := msg.getFocus & (msg.focus # c) + ELSIF IsShortcut(msg.char, c) THEN + msg.accepts := TRUE; msg.getFocus := StdCFrames.setFocus + ELSIF msg.char # " " THEN + msg.accepts := FALSE + END + END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.hotFocus := TRUE; msg.setFocus := StdCFrames.setFocus + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetRadioButtonSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, level} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: RadioButton) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + IF name = "List" THEN c.item.Lookup("index", c.item) END; + ok := (c.item.typ >= Meta.byteTyp) & (c.item.typ <= Meta.intTyp) OR (c.item.typ = Meta.boolTyp) + END CheckLink; + + PROCEDURE (c: RadioButton) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + IF (op = 0) OR (c.prop.level = to) OR (c.prop.level = from) THEN + f(StdCFrames.RadioButton).label := c.label$; + f(StdCFrames.Frame).Update + END + END Update; + + + (* Field *) + + PROCEDURE LongToString (x: LONGINT; OUT s: ARRAY OF CHAR); + VAR d: ARRAY 24 OF CHAR; i, j: INTEGER; + BEGIN + IF x = MIN(LONGINT) THEN + s := "-9223372036854775808" + ELSE + i := 0; j := 0; + IF x < 0 THEN s[0] := "-"; i := 1; x := -x END; + REPEAT d[j] := CHR(x MOD 10 + ORD("0")); INC(j); x := x DIV 10 UNTIL x = 0; + WHILE j > 0 DO DEC(j); s[i] := d[j]; INC(i) END; + s[i] := 0X + END + END LongToString; + + PROCEDURE StringToLong (IN s: ARRAY OF CHAR; OUT x: LONGINT; OUT res: INTEGER); + VAR i, sign, d: INTEGER; + BEGIN + i := 0; sign := 1; x := 0; res := 0; + WHILE s[i] = " " DO INC(i) END; + IF s[i] = "-" THEN sign := -1; INC(i) END; + WHILE s[i] = " " DO INC(i) END; + IF s[i] = 0X THEN res := 2 END; + WHILE (s[i] >= "0") & (s[i] <= "9") DO + d := ORD(s[i]) - ORD("0"); INC(i); + IF x <= (MAX(LONGINT) - d) DIV 10 THEN x := 10 * x + d + ELSE res := 1 + END + END; + x := x * sign; + IF s[i] # 0X THEN res := 2 END + END StringToLong; + + PROCEDURE FixToInt (fix: ARRAY OF CHAR; OUT int: ARRAY OF CHAR; scale: INTEGER); + VAR i, j: INTEGER; + BEGIN + IF scale > 24 THEN scale := 24 ELSIF scale < 0 THEN scale := 0 END; + i := 0; j := 0; + WHILE (fix[i] # ".") & (fix[i] # 0X) DO int[j] := fix[i]; INC(i); INC(j) END; + IF fix[i] = "." THEN INC(i) END; + WHILE (scale > 0) & (fix[i] >= "0") & (fix[i] <= "9") DO int[j] := fix[i]; INC(i); INC(j); DEC(scale) END; + WHILE scale > 0 DO int[j] := "0"; INC(j); DEC(scale) END; + int[j] := 0X + END FixToInt; + + PROCEDURE IntToFix (int: ARRAY OF CHAR; OUT fix: ARRAY OF CHAR; scale: INTEGER); + VAR i, j, n: INTEGER; + BEGIN + IF scale > 24 THEN scale := 24 ELSIF scale < 0 THEN scale := 0 END; + n := LEN(int$); i := 0; j := 0; + WHILE int[i] < "0" DO fix[j] := int[i]; INC(i); INC(j); DEC(n) END; + IF n > scale THEN + WHILE n > scale DO fix[j] := int[i]; INC(i); INC(j); DEC(n) END + ELSE + fix[j] := "0"; INC(j) + END; + fix[j] := "."; INC(j); + WHILE n < scale DO fix[j] := "0"; INC(j); DEC(scale) END; + WHILE n > 0 DO fix[j] := int[i]; INC(i); INC(j); DEC(n) END; + fix[j] := 0X + END IntToFix; + + PROCEDURE GetField (f: StdCFrames.Field; OUT x: ARRAY OF CHAR); + VAR c: Field; ok: BOOLEAN; b, v: Meta.Item; mod, name: Meta.Name; + BEGIN + x := ""; + c := f.view(Field); + IF c.item.Valid() THEN + IF c.item.typ = Meta.arrTyp THEN + c.item.GetStringVal(x, ok) + ELSIF c.item.typ IN {Meta.byteTyp, Meta.sIntTyp, Meta.intTyp} THEN + Strings.IntToString(c.item.IntVal(), x); + IF c.prop.level > 0 THEN IntToFix(x, x, c.prop.level) END + ELSIF c.item.typ = Meta.longTyp THEN + LongToString(c.item.LongVal(), x); + IF c.prop.level > 0 THEN IntToFix(x, x, c.prop.level) END + ELSIF c.item.typ = Meta.sRealTyp THEN + IF c.prop.level <= 0 THEN + Strings.RealToStringForm(c.item.RealVal(), 7, 0, c.prop.level, " ", x) + ELSE + Strings.RealToStringForm(c.item.RealVal(), c.prop.level, 0, 1, " ", x) + END + ELSIF c.item.typ = Meta.realTyp THEN + IF c.prop.level <= 0 THEN + Strings.RealToStringForm(c.item.RealVal(), 16, 0, c.prop.level, " ", x) + ELSE + Strings.RealToStringForm(c.item.RealVal(), c.prop.level, 0, 1, " ", x) + END + ELSIF c.item.typ = Meta.recTyp THEN + c.item.GetTypeName(mod, name); + IF mod = "Dialog" THEN + IF name = "Currency" THEN + c.item.Lookup("val", v); c.item.Lookup("scale", b); + LongToString(v.LongVal(), x); IntToFix(x, x, b.IntVal()) + ELSE (* Combo *) + c.item.Lookup("item", v); (* Combo *) + IF v.typ = Meta.arrTyp THEN v.GetStringVal(x, ok) END + END + END + END + ELSE + x := c.label$ + END + END GetField; + + PROCEDURE SetField (f: StdCFrames.Field; IN x: ARRAY OF CHAR); + VAR c: Field; ok: BOOLEAN; i, res, old: INTEGER; r, or: REAL; b, v: Meta.Item; + mod, name: Meta.Name; long, long0: LONGINT; + s: ARRAY 1024 OF CHAR; + BEGIN + c := f.view(Field); + IF c.item.Valid() & ~c.readOnly THEN + CASE c.item.typ OF + | Meta.arrTyp: + c.item.GetStringVal(s, ok); + IF ~ok OR (s$ # x$) THEN + c.item.PutStringVal(x, ok); + IF ok THEN Notify(c, f, Dialog.changed, 0, 0) ELSE Dialog.Beep END + END + | Meta.byteTyp: + IF x = "" THEN i := 0; res := 0 + ELSIF c.prop.level > 0 THEN FixToInt(x, s, c.prop.level); Strings.StringToInt(s, i, res) + ELSE Strings.StringToInt(x, i, res) + END; + IF (res = 0) & (i >= MIN(BYTE)) & (i <= MAX(BYTE)) THEN + old := c.item.IntVal(); + IF i # old THEN c.item.PutIntVal(i); Notify(c, f, Dialog.changed, old, i) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.sIntTyp: + IF x = "" THEN i := 0; res := 0 + ELSIF c.prop.level > 0 THEN FixToInt(x, s, c.prop.level); Strings.StringToInt(s, i, res) + ELSE Strings.StringToInt(x, i, res) + END; + IF (res = 0) & (i >= MIN(SHORTINT)) & (i <= MAX(SHORTINT)) THEN + old := c.item.IntVal(); + IF i # old THEN c.item.PutIntVal(i); Notify(c, f, Dialog.changed, old, i) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.intTyp: + IF x = "" THEN i := 0; res := 0 + ELSIF c.prop.level > 0 THEN FixToInt(x, s, c.prop.level); Strings.StringToInt(s, i, res) + ELSE Strings.StringToInt(x, i, res) + END; + IF res = 0 THEN + old := c.item.IntVal(); + IF i # old THEN c.item.PutIntVal(i); Notify(c, f, Dialog.changed, old, i) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.longTyp: + IF x = "" THEN long := 0; res := 0 + ELSE FixToInt(x, s, c.prop.level); StringToLong(s, long, res) + END; + IF res = 0 THEN + long0 := c.item.LongVal(); + IF long # long0 THEN c.item.PutLongVal(long); Notify(c, f, Dialog.changed, 0, 0) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.sRealTyp: + IF (x = "") OR (x = "-") THEN r := 0; res := 0 ELSE Strings.StringToReal(x, r, res) END; + IF (res = 0) & (r >= MIN(SHORTREAL)) & (r <= MAX(SHORTREAL)) THEN + or := c.item.RealVal(); + IF r # or THEN c.item.PutRealVal(r); Notify(c, f, Dialog.changed, 0, 0) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.realTyp: + IF (x = "") OR (x = "-") THEN r := 0; res := 0 ELSE Strings.StringToReal(x, r, res) END; + IF res = 0 THEN + or := c.item.RealVal(); + IF r # or THEN c.item.PutRealVal(r); Notify(c, f, Dialog.changed, 0, 0) END + ELSIF x # "-" THEN + Dialog.Beep + END + | Meta.recTyp: + c.item.GetTypeName(mod, name); + IF mod = "Dialog" THEN + IF name = "Currency" THEN + c.item.Lookup("val", v); c.item.Lookup("scale", b); + IF x = "" THEN long := 0; res := 0 + ELSE FixToInt(x, s, b.IntVal()); StringToLong(s, long, res) + END; + IF res = 0 THEN + long0 := v.LongVal(); + IF long # long0 THEN v.PutLongVal(long); Notify(c, f, Dialog.changed, 0, 0) END + ELSIF x # "-" THEN + Dialog.Beep + END + ELSE (* name = "Combo" *) + c.item.Lookup("item", v); + IF v.typ = Meta.arrTyp THEN + v.GetStringVal(s, ok); + IF ~ok OR (s$ # x$) THEN + v.PutStringVal(x, ok); + IF ok THEN Notify(c, f, Dialog.changed, 0, 0) ELSE Dialog.Beep END + END + END + END + END + END + END + END SetField; + + PROCEDURE EqualField (f: StdCFrames.Field; IN s1, s2: ARRAY OF CHAR): BOOLEAN; + VAR c: Field; i1, i2, res1, res2: INTEGER; r1, r2: REAL; l1, l2: LONGINT; + mod, name: Meta.Name; t1, t2: ARRAY 64 OF CHAR; b: Meta.Item; + BEGIN + c := f.view(Field); + CASE c.item.typ OF + | Meta.arrTyp: + RETURN s1 = s2 + | Meta.byteTyp, Meta.sIntTyp, Meta.intTyp: + IF c.prop.level > 0 THEN + FixToInt(s1, t1, c.prop.level); Strings.StringToInt(t1, i1, res1); + FixToInt(s2, t2, c.prop.level); Strings.StringToInt(t2, i2, res2) + ELSE + Strings.StringToInt(s1, i1, res1); + Strings.StringToInt(s2, i2, res2) + END; + RETURN (res1 = 0) & (res2 = 0) & (i1 = i2) + | Meta.longTyp: + IF c.prop.level > 0 THEN + FixToInt(s1, t1, c.prop.level); StringToLong(t1, l1, res1); + FixToInt(s2, t2, c.prop.level); StringToLong(t2, l2, res2) + ELSE + StringToLong(s1, l1, res1); + StringToLong(s2, l2, res2) + END; + RETURN (res1 = 0) & (res2 = 0) & (l1 = l2) + | Meta.sRealTyp, Meta.realTyp: + Strings.StringToReal(s1, r1, res1); + Strings.StringToReal(s2, r2, res2); + RETURN (res1 = 0) & (res2 = 0) & (r1 = r2) + | Meta.recTyp: + c.item.GetTypeName(mod, name); + IF mod = "Dialog" THEN + IF name = "Currency" THEN + c.item.Lookup("scale", b); i1 := b.IntVal(); + FixToInt(s1, t1, i1); StringToLong(t1, l1, res1); + FixToInt(s2, t2, i1); StringToLong(t2, l2, res2); + RETURN (res1 = 0) & (res2 = 0) & (l1 =l2) + ELSE (* name = "Combo" *) + RETURN s1 = s2 + END + END + ELSE RETURN s1 = s2 + END + END EqualField; + + PROCEDURE (c: Field) CopyFromSimpleView2 (source: Control); + BEGIN + WITH source: Field DO c.maxLen := source.maxLen END + END CopyFromSimpleView2; + + PROCEDURE (c: Field) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, fldVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: Field) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(fldVersion) + END Externalize2; + + PROCEDURE (c: Field) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.Field; + BEGIN + f := StdCFrames.dir.NewField(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.maxLen := c.maxLen; + f.left := c.prop.opt[left]; + f.right := c.prop.opt[right]; + f.multiLine := c.prop.opt[multiLine]; + f.password := c.prop.opt[password]; + f.Get := GetField; + f.Set := SetField; + f.Equal := EqualField; + frame := f + END GetNewFrame; + + PROCEDURE (c: Field) 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 (c: Field) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + VAR ch: CHAR; mod, name: Meta.Name; + BEGIN + WITH f: StdCFrames.Field DO + IF ~c.disabled & ~c.readOnly THEN + WITH msg: Controllers.PollOpsMsg DO + msg.selectable := TRUE; + (* should ask Frame if there is a selection for cut or copy! *) + msg.valid := {Controllers.pasteChar, Controllers.cut, Controllers.copy, Controllers.paste} + | msg: Controllers.TickMsg DO + f.Idle + | msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + ch := msg.char; + IF (ch = ldel) OR (ch = rdel) OR (ch >= 10X) & (ch <= 1FX) + OR ("0" <= ch) & (ch <= "9") OR (ch = "+") OR (ch = "-") + OR (c.item.typ = Meta.arrTyp) + OR (c.item.typ IN {Meta.sRealTyp, Meta.realTyp}) & ((ch = ".") OR (ch = "E")) + OR (c.prop.level > 0) & (ch = ".") + THEN f.KeyDown(ch) + ELSIF c.item.typ = Meta.recTyp THEN + c.item.GetTypeName(mod, name); + IF (mod = "Dialog") & (name = "Combo") OR (ch = ".") THEN + f.KeyDown(ch) + ELSE Dialog.Beep + END + ELSE Dialog.Beep + END + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + | msg: Controllers.SelectMsg DO + IF msg.set THEN f.Select(0, MAX(INTEGER)) + ELSE f.Select(-1, -1) + END + | msg: Controllers.MarkMsg DO + f.Mark(msg.show, msg.focus); + IF ~msg.show & msg.focus THEN f.Update END; + IF msg.show & msg.focus THEN f.Select(0, MAX(INTEGER)) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + ELSIF ~c.disabled THEN + WITH msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + ELSE + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: Field) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF msg.char = lineChar THEN msg.accepts := c.prop.opt[multiLine] & (msg.focus = c) + ELSIF msg.char = esc THEN msg.accepts := FALSE + END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + ELSIF~c.disabled THEN + msg.hotFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetFieldSize(c.maxLen, msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, level, notifier, left, right, multiLine, password} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: Field) CheckLink (VAR ok: BOOLEAN); + VAR t: INTEGER; name: Meta.Name; + BEGIN + GetTypeName(c.item, name); t := c.item.typ; + IF (t = Meta.arrTyp) & (c.item.BaseTyp() = Meta.charTyp) THEN c.maxLen := SHORT(c.item.Len() - 1) + ELSIF t = Meta.byteTyp THEN c.maxLen := 6 + ELSIF t = Meta.sIntTyp THEN c.maxLen := 9 + ELSIF t = Meta.intTyp THEN c.maxLen := 13 + ELSIF t = Meta.longTyp THEN c.maxLen := 24 + ELSIF t = Meta.sRealTyp THEN c.maxLen := 16 + ELSIF t = Meta.realTyp THEN c.maxLen := 24 + ELSIF name = "Combo" THEN c.maxLen := 64 + ELSIF name = "Currency" THEN c.maxLen := 16 + ELSE ok := FALSE + END + END CheckLink; + + PROCEDURE (c: Field) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* UpDownField *) + + PROCEDURE GetUpDownField (f: StdCFrames.UpDownField; OUT val: INTEGER); + VAR c: UpDownField; + BEGIN + val := 0; + c := f.view(UpDownField); + IF c.item.Valid() THEN val := c.item.IntVal() END + END GetUpDownField; + + PROCEDURE SetUpDownField (f: StdCFrames.UpDownField; val: INTEGER); + VAR c: UpDownField; old: INTEGER; + BEGIN + c := f.view(UpDownField); + IF c.item.Valid() & ~c.readOnly THEN + IF (val >= c.min) & (val <= c.max) THEN + old := c.item.IntVal(); + IF old # val THEN c.item.PutIntVal(val); Notify(c, f, Dialog.changed, old, val) END + ELSE Dialog.Beep + END + END + END SetUpDownField; + + PROCEDURE (c: UpDownField) CopyFromSimpleView2 (source: Control); + BEGIN + WITH source: UpDownField DO + c.min := source.min; + c.max := source.max; + c.inc := source.inc + END + END CopyFromSimpleView2; + + PROCEDURE (c: UpDownField) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, fldVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: UpDownField) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(fldVersion) + END Externalize2; + + PROCEDURE (c: UpDownField) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.UpDownField; + BEGIN + f := StdCFrames.dir.NewUpDownField(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.min := c.min; + f.max := c.max; + f.inc := c.inc; + f.Get := GetUpDownField; + f.Set := SetUpDownField; + frame := f + END GetNewFrame; + + PROCEDURE (c: UpDownField) 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 (c: UpDownField) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + VAR ch: CHAR; + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.UpDownField DO + WITH msg: Controllers.PollOpsMsg DO + msg.selectable := TRUE; + (* should ask view if there is a selection for cut or copy! *) + msg.valid := {Controllers.pasteChar, Controllers.cut, Controllers.copy, Controllers.paste} + | msg: Controllers.TickMsg DO + f.Idle + | msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + ch := msg.char; + IF (ch = ldel) OR (ch = rdel) OR (ch >= 10X) & (ch <= 1FX) + OR ("0" <= ch) & (ch <= "9") OR (ch = "+") OR (ch = "-") + OR (c.item.typ = Meta.arrTyp) + THEN f.KeyDown(ch) + ELSE Dialog.Beep + END + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + | msg: Controllers.SelectMsg DO + IF msg.set THEN f.Select(0, MAX(INTEGER)) + ELSE f.Select(-1, -1) + END + | msg: Controllers.MarkMsg DO + f.Mark(msg.show, msg.focus); + IF msg.show & msg.focus THEN f.Select(0, MAX(INTEGER)) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: UpDownField) HandlePropMsg2 (VAR msg: Properties.Message); + VAR m: INTEGER; n: INTEGER; + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + END + | msg: Properties.SizePref DO + m := -c.min; + IF c.max > m THEN m := c.max END; + n := 3; + WHILE m > 99 DO INC(n); m := m DIV 10 END; + StdCFrames.dir.GetUpDownFieldSize(n, msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: UpDownField) CheckLink (VAR ok: BOOLEAN); + BEGIN + IF c.item.typ = Meta.byteTyp THEN c.min := MIN(BYTE); c.max := MAX(BYTE) + ELSIF c.item.typ = Meta.sIntTyp THEN c.min := MIN(SHORTINT); c.max := MAX(SHORTINT) + ELSIF c.item.typ = Meta.intTyp THEN c.min := MIN(INTEGER); c.max := MAX(INTEGER) + ELSE ok := FALSE + END; + c.inc := 1 + END CheckLink; + + PROCEDURE (c: UpDownField) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* DateField *) + + PROCEDURE GetDateField (f: StdCFrames.DateField; OUT date: Dates.Date); + VAR c: DateField; v: Meta.Item; + BEGIN + date.year := 1; date.month := 1; date.day := 1; + c := f.view(DateField); + IF c.item.Valid() THEN + c.item.Lookup("year", v); IF v.typ = Meta.intTyp THEN date.year := SHORT(v.IntVal()) END; + c.item.Lookup("month", v); IF v.typ = Meta.intTyp THEN date.month := SHORT(v.IntVal()) END; + c.item.Lookup("day", v); IF v.typ = Meta.intTyp THEN date.day := SHORT(v.IntVal()) END + END + END GetDateField; + + PROCEDURE SetDateField(f: StdCFrames.DateField; IN date: Dates.Date); + VAR c: DateField; v: Meta.Item; + BEGIN + c := f.view(DateField); + IF c.item.Valid() & ~c.readOnly THEN + c.item.Lookup("year", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.year) END; + c.item.Lookup("month", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.month) END; + c.item.Lookup("day", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.day) END; + Notify(c, f, Dialog.changed, 0, 0) + END + END SetDateField; + + PROCEDURE GetDateFieldSelection (f: StdCFrames.DateField; OUT sel: INTEGER); + BEGIN + sel := f.view(DateField).selection + END GetDateFieldSelection; + + PROCEDURE SetDateFieldSelection (f: StdCFrames.DateField; sel: INTEGER); + BEGIN + f.view(DateField).selection := sel + END SetDateFieldSelection; + + PROCEDURE (c: DateField) CopyFromSimpleView2 (source: Control); + BEGIN + WITH source: DateField DO c.selection := source.selection END + END CopyFromSimpleView2; + + PROCEDURE (c: DateField) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, dfldVersion, thisVersion); + c.selection := 0 + END Internalize2; + + PROCEDURE (c: DateField) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(dfldVersion) + END Externalize2; + + PROCEDURE (c: DateField) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.DateField; + BEGIN + f := StdCFrames.dir.NewDateField(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.Get := GetDateField; + f.Set := SetDateField; + f.GetSel := GetDateFieldSelection; + f.SetSel := SetDateFieldSelection; + frame := f + END GetNewFrame; + + PROCEDURE (c: DateField) 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 (c: DateField) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.DateField DO + WITH msg: Controllers.PollOpsMsg DO + msg.valid := {Controllers.pasteChar, Controllers.copy} + | msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + f.KeyDown(msg.char) + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + | msg: Controllers.TickMsg DO + IF f.mark THEN + IF c.selection = 0 THEN c.selection := 1; Views.Update(c, Views.keepFrames) END + END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: DateField) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN + msg.accepts := FALSE + ELSIF (msg.char = tab) OR (msg.char = ltab) THEN + msg.accepts := ((msg.focus # c) & (~c.disabled & ~c.readOnly)) OR + (msg.focus = c) & ((msg.char = tab) & (c.selection # -1) OR (msg.char = ltab) & (c.selection # 1)); + msg.getFocus := msg.accepts + END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetDateFieldSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: DateField) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "Date" + END CheckLink; + + PROCEDURE (c: DateField) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* TimeField *) + + PROCEDURE GetTimeField (f: StdCFrames.TimeField; OUT time: Dates.Time); + VAR c: TimeField; v: Meta.Item; + BEGIN + time.hour := 0; time.minute := 0; time.second := 0; + c := f.view(TimeField); + IF c.item.Valid() THEN + c.item.Lookup("hour", v); IF v.typ = Meta.intTyp THEN time.hour := SHORT(v.IntVal()) END; + c.item.Lookup("minute", v); IF v.typ = Meta.intTyp THEN time.minute := SHORT(v.IntVal()) END; + c.item.Lookup("second", v); IF v.typ = Meta.intTyp THEN time.second := SHORT(v.IntVal()) END + END + END GetTimeField; + + PROCEDURE SetTimeField(f: StdCFrames.TimeField; IN date: Dates.Time); + VAR c: TimeField; v: Meta.Item; + BEGIN + c := f.view(TimeField); + IF c.item.Valid() & ~c.readOnly THEN + c.item.Lookup("hour", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.hour) END; + c.item.Lookup("minute", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.minute) END; + c.item.Lookup("second", v); IF v.typ = Meta.intTyp THEN v.PutIntVal(date.second) END; + Notify(c, f, Dialog.changed, 0, 0) + END + END SetTimeField; + + PROCEDURE GetTimeFieldSelection (f: StdCFrames.TimeField; OUT sel: INTEGER); + BEGIN + sel := f.view(TimeField).selection + END GetTimeFieldSelection; + + PROCEDURE SetTimeFieldSelection (f: StdCFrames.TimeField; sel: INTEGER); + BEGIN + f.view(TimeField).selection := sel + END SetTimeFieldSelection; + + PROCEDURE (c: TimeField) CopyFromSimpleView2 (source: Control); + BEGIN + WITH source: TimeField DO c.selection := source.selection END + END CopyFromSimpleView2; + + PROCEDURE (c: TimeField) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, tfldVersion, thisVersion); + c.selection := 0 + END Internalize2; + + PROCEDURE (c: TimeField) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(tfldVersion) + END Externalize2; + + PROCEDURE (c: TimeField) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.TimeField; + BEGIN + f := StdCFrames.dir.NewTimeField(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.Get := GetTimeField; + f.Set := SetTimeField; + f.GetSel := GetTimeFieldSelection; + f.SetSel := SetTimeFieldSelection; + frame := f + END GetNewFrame; + + PROCEDURE (c: TimeField) 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 (c: TimeField) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.TimeField DO + WITH msg: Controllers.PollOpsMsg DO + msg.valid := {Controllers.pasteChar, Controllers.copy} + | msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + f.KeyDown(msg.char) + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + | msg: Controllers.TickMsg DO + IF f.mark THEN + IF c.selection = 0 THEN c.selection := 1; Views.Update(c, Views.keepFrames) END + END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: TimeField) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN + msg.accepts := FALSE + ELSIF (msg.char = tab) OR (msg.char = ltab) THEN + msg.accepts := (msg.focus # c) OR + ((msg.char = tab) & (c.selection # -1)) OR ((msg.char = ltab) & (c.selection # 1)) + END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetTimeFieldSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: TimeField) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "Time" + END CheckLink; + + PROCEDURE (c: TimeField) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* ColorField *) + + PROCEDURE GetColorField (f: StdCFrames.ColorField; OUT col: INTEGER); + VAR c: ColorField; v: Meta.Item; + BEGIN + col := Ports.defaultColor; + c := f.view(ColorField); + IF c.item.Valid() THEN + IF c.item.typ = Meta.intTyp THEN + col := c.item.IntVal() + ELSE + c.item.Lookup("val", v); IF v.typ = Meta.intTyp THEN col := v.IntVal() END + END + END + END GetColorField; + + PROCEDURE SetColorField(f: StdCFrames.ColorField; col: INTEGER); + VAR c: ColorField; v: Meta.Item; old: INTEGER; + BEGIN + c := f.view(ColorField); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.typ = Meta.intTyp THEN + old := c.item.IntVal(); + IF old # col THEN c.item.PutIntVal(col); Notify(c, f, Dialog.changed, old, col) END + ELSE + c.item.Lookup("val", v); + IF v.typ = Meta.intTyp THEN + old := v.IntVal(); + IF old # col THEN v.PutIntVal(col); Notify(c, f, Dialog.changed, old, col) END + END + END + END + END SetColorField; + + PROCEDURE (c: ColorField) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, cfldVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: ColorField) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(cfldVersion) + END Externalize2; + + PROCEDURE (c: ColorField) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.ColorField; + BEGIN + f := StdCFrames.dir.NewColorField(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.Get := GetColorField; + f.Set := SetColorField; + frame := f + END GetNewFrame; + + PROCEDURE (c: ColorField) 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 (c: ColorField) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + IF ~c.disabled & ~c.readOnly THEN + WITH f: StdCFrames.ColorField DO + WITH msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + f.KeyDown(msg.char) + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: ColorField) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + msg.accepts := ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.hotFocus := TRUE; msg.setFocus := StdCFrames.setFocus + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetColorFieldSize(msg.w, msg.h) + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: ColorField) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := (name = "Color") OR (c.item.typ = Meta.intTyp) + END CheckLink; + + PROCEDURE (c: ColorField) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* ListBox *) + + PROCEDURE GetListBox (f: StdCFrames.ListBox; OUT i: INTEGER); + VAR c: ListBox; v: Meta.Item; + BEGIN + i := -1; + c := f.view(ListBox); + IF c.item.Valid() THEN + c.item.Lookup("index", v); + IF v.typ = Meta.intTyp THEN i := v.IntVal() END + END + END GetListBox; + + PROCEDURE SetListBox (f: StdCFrames.ListBox; i: INTEGER); + VAR c: ListBox; v: Meta.Item; old: INTEGER; + BEGIN + c := f.view(ListBox); + IF c.item.Valid() & ~c.readOnly THEN + c.item.Lookup("index", v); + IF v.typ = Meta.intTyp THEN + old := v.IntVal(); + IF i # old THEN v.PutIntVal(i); Notify(c, f, Dialog.changed, old, i) END + END + END + END SetListBox; + + PROCEDURE GetFName (VAR rec, par: ANYREC); + BEGIN + WITH par: Param DO + WITH rec: Dialog.List DO rec.GetItem(par.i, par.n) + | rec: Dialog.Selection DO rec.GetItem(par.i, par.n) + | rec: Dialog.Combo DO rec.GetItem(par.i, par.n) + ELSE par.n := "" + END + END + END GetFName; + + PROCEDURE GetListName (f: StdCFrames.ListBox; i: INTEGER; VAR name: ARRAY OF CHAR); + VAR c: ListBox; par: Param; + BEGIN + par.n := ""; + c := f.view(ListBox); + IF c.item.Valid() THEN + par.i := i; + c.item.CallWith(GetFName, par) + END; + name := par.n$ + END GetListName; + + PROCEDURE (c: ListBox) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, lbxVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: ListBox) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(lbxVersion) + END Externalize2; + + PROCEDURE (c: ListBox) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.ListBox; + BEGIN + f := StdCFrames.dir.NewListBox(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.sorted := c.prop.opt[sorted]; + f.Get := GetListBox; + f.Set := SetListBox; + f.GetName := GetListName; + frame := f + END GetNewFrame; + + PROCEDURE (c: ListBox) 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 (c: ListBox) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH f: StdCFrames.ListBox DO + IF ~c.disabled & ~c.readOnly THEN + WITH msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN f.KeyDown(msg.char) END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + ELSIF ~c.disabled THEN + WITH msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + ELSE + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: ListBox) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + ELSIF~c.disabled THEN + msg.hotFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetListBoxSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, sorted} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: ListBox) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "List" + END CheckLink; + + PROCEDURE (c: ListBox) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + PROCEDURE (c: ListBox) UpdateList (f: Views.Frame); + BEGIN + f(StdCFrames.Frame).UpdateList + END UpdateList; + + + (* SelectionBox *) + + PROCEDURE InLargeSet (VAR rec, par: ANYREC); + BEGIN + WITH par: Param DO + WITH rec: Dialog.Selection DO + IF rec.In(par.i) THEN par.i := 1 ELSE par.i := 0 END + ELSE par.i := 0 + END + END + END InLargeSet; + + PROCEDURE GetSelectionBox (f: StdCFrames.SelectionBox; i: INTEGER; OUT in: BOOLEAN); + VAR c: SelectionBox; lv: SelectValue; par: Param; + BEGIN + in := FALSE; + c := f.view(SelectionBox); + IF c.item.Valid() THEN + IF c.item.Is(lv) THEN + par.i := i; + c.item.CallWith(InLargeSet, par); + in := par.i # 0 + END + END + END GetSelectionBox; + + PROCEDURE InclLargeSet (VAR rec, par: ANYREC); + BEGIN + WITH par: Param DO + WITH rec: Dialog.Selection DO + IF (par.from # par.to) OR ~rec.In(par.from) THEN + rec.Incl(par.from, par.to); par.i := 1 + ELSE par.i := 0 + END + ELSE par.i := 0 + END + END + END InclLargeSet; + + PROCEDURE InclSelectionBox (f: StdCFrames.SelectionBox; from, to: INTEGER); + VAR c: SelectionBox; lv: SelectValue; par: Param; + BEGIN + c := f.view(SelectionBox); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.Is(lv) THEN + par.from := from; par.to := to; + c.item.CallWith(InclLargeSet, par); + IF par.i # 0 THEN Notify(c, f, Dialog.included, from, to) END + END + END + END InclSelectionBox; + + PROCEDURE ExclLargeSet (VAR rec, par: ANYREC); + BEGIN + WITH par: Param DO + WITH rec: Dialog.Selection DO + IF (par.from # par.to) OR rec.In(par.from) THEN + rec.Excl(par.from, par.to); par.i := 1 + ELSE par.i := 0 + END + ELSE par.i := 0 + END + END + END ExclLargeSet; + + PROCEDURE ExclSelectionBox (f: StdCFrames.SelectionBox; from, to: INTEGER); + VAR c: SelectionBox; lv: SelectValue; par: Param; + BEGIN + c := f.view(SelectionBox); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.Is(lv) THEN + par.from := from; par.to := to; + c.item.CallWith(ExclLargeSet, par); + IF par.i # 0 THEN Notify(c, f, Dialog.excluded, from, to) END + END + END + END ExclSelectionBox; + + PROCEDURE SetSelectionBox (f: StdCFrames.SelectionBox; from, to: INTEGER); + VAR c: SelectionBox; lv: SelectValue; par: Param; + BEGIN + c := f.view(SelectionBox); + IF c.item.Valid() & ~c.readOnly THEN + IF c.item.Is(lv) THEN + par.from := 0; par.to := MAX(INTEGER); + c.item.CallWith(ExclLargeSet, par); + par.from := from; par.to := to; + c.item.CallWith(InclLargeSet, par); + Notify(c, f, Dialog.set, from, to) + END + END + END SetSelectionBox; + + PROCEDURE GetSelName (f: StdCFrames.SelectionBox; i: INTEGER; VAR name: ARRAY OF CHAR); + VAR c: SelectionBox; par: Param; + BEGIN + par.n := ""; + c := f.view(SelectionBox); + IF c.item.Valid() THEN + par.i := i; + c.item.CallWith(GetFName, par) + END; + name := par.n$ + END GetSelName; + + PROCEDURE (c: SelectionBox) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, sbxVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: SelectionBox) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(sbxVersion) + END Externalize2; + + PROCEDURE (c: SelectionBox) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.SelectionBox; + BEGIN + f := StdCFrames.dir.NewSelectionBox(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.sorted := c.prop.opt[sorted]; + f.Get := GetSelectionBox; + f.Incl := InclSelectionBox; + f.Excl := ExclSelectionBox; + f.Set := SetSelectionBox; + f.GetName := GetSelName; + frame := f + END GetNewFrame; + + PROCEDURE (c: SelectionBox) 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 (c: SelectionBox) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH f: StdCFrames.SelectionBox DO + IF ~c.disabled & ~c.readOnly THEN + WITH msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN f.KeyDown(msg.char) END + | msg: Controllers.SelectMsg DO + IF msg.set THEN f.Select(0, MAX(INTEGER)) + ELSE f.Select(-1, -1) + END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + ELSIF ~c.disabled THEN + WITH msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + ELSE + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: SelectionBox) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) OR msg.getFocus THEN + msg.getFocus := StdCFrames.setFocus + END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + ELSIF~c.disabled THEN + msg.hotFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetSelectionBoxSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, sorted} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: SelectionBox) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "Selection" + END CheckLink; + + PROCEDURE (c: SelectionBox) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + IF (op >= Dialog.included) & (op <= Dialog.set) THEN + f(StdCFrames.SelectionBox).UpdateRange(op, from, to) + ELSE + f(StdCFrames.Frame).Update + END + END Update; + + PROCEDURE (c: SelectionBox) UpdateList (f: Views.Frame); + BEGIN + f(StdCFrames.Frame).UpdateList + END UpdateList; + + + (* ComboBox *) + + PROCEDURE GetComboBox (f: StdCFrames.ComboBox; OUT x: ARRAY OF CHAR); + VAR c: ComboBox; ok: BOOLEAN; v: Meta.Item; + BEGIN + x := ""; + c := f.view(ComboBox); + IF c.item.Valid() THEN + c.item.Lookup("item", v); + IF v.typ = Meta.arrTyp THEN v.GetStringVal(x, ok) END + END + END GetComboBox; + + PROCEDURE SetComboBox (f: StdCFrames.ComboBox; IN x: ARRAY OF CHAR); + VAR c: ComboBox; ok: BOOLEAN; v: Meta.Item; s: ARRAY 1024 OF CHAR; + BEGIN + c := f.view(ComboBox); + IF c.item.Valid() & ~c.readOnly THEN + c.item.Lookup("item", v); + IF v.typ = Meta.arrTyp THEN + v.GetStringVal(s, ok); + IF ~ok OR (s$ # x$) THEN + v.PutStringVal(x, ok); + IF ok THEN Notify(c, f, Dialog.changed, 0, 0) END + END + END + END + END SetComboBox; + + PROCEDURE GetComboName (f: StdCFrames.ComboBox; i: INTEGER; VAR name: ARRAY OF CHAR); + VAR c: ComboBox; par: Param; + BEGIN + par.n := ""; + c := f.view(ComboBox); + IF c.item.Valid() THEN + par.i := i; + c.item.CallWith(GetFName, par) + END; + name := par.n$ + END GetComboName; + + PROCEDURE (c: ComboBox) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, cbxVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: ComboBox) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(cbxVersion) + END Externalize2; + + PROCEDURE (c: ComboBox) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.ComboBox; + BEGIN + f := StdCFrames.dir.NewComboBox(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.sorted := c.prop.opt[sorted]; + f.Get := GetComboBox; + f.Set := SetComboBox; + f.GetName := GetComboName; + frame := f + END GetNewFrame; + + PROCEDURE (c: ComboBox) 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 (c: ComboBox) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH f: StdCFrames.ComboBox DO + IF ~c.disabled & ~c.readOnly THEN + WITH msg: Controllers.PollOpsMsg DO + msg.selectable := TRUE; + (* should ask Frame if there is a selection for cut or copy! *) + msg.valid := {Controllers.pasteChar, Controllers.cut, Controllers.copy, Controllers.paste} + | msg: Controllers.TickMsg DO + f.Idle + | msg: Controllers.EditMsg DO + IF msg.op = Controllers.pasteChar THEN + f.KeyDown(msg.char) + ELSE + f.Edit(msg.op, msg.view, msg.w, msg.h, msg.isSingle, msg.clipboard) + END + | msg: Controllers.SelectMsg DO + IF msg.set THEN f.Select(0, MAX(INTEGER)) + ELSE f.Select(-1, -1) + END + | msg: Controllers.MarkMsg DO + f.Mark(msg.show, msg.focus); + IF msg.show & msg.focus THEN f.Select(0, MAX(INTEGER)) END + | msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: ComboBox) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) THEN msg.getFocus := TRUE END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetComboBoxSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, sorted} + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: ComboBox) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "Combo" + END CheckLink; + + PROCEDURE (c: ComboBox) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + PROCEDURE (c: ComboBox) UpdateList (f: Views.Frame); + BEGIN + f(StdCFrames.Frame).UpdateList + END UpdateList; + + + (* Caption *) + + PROCEDURE (c: Caption) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, capVersion, thisVersion); + IF thisVersion < 1 THEN c.prop.opt[left] := TRUE END + END Internalize2; + + PROCEDURE (c: Caption) Externalize2 (VAR wr: Stores.Writer); + BEGIN + (* Save old version for captions that are compatible with the old version *) + IF c.prop.opt[left] THEN wr.WriteVersion(0) ELSE wr.WriteVersion(capVersion) END + END Externalize2; + + PROCEDURE (c: Caption) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.Caption; + BEGIN + f := StdCFrames.dir.NewCaption(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.label := c.label$; + f.left := c.prop.opt[left]; + f.right := c.prop.opt[right]; + frame := f + END GetNewFrame; + + PROCEDURE (c: Caption) 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 (c: Caption) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.SizePref DO + StdCFrames.dir.GetCaptionSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, left, right} + | msg: DefaultsPref DO + IF c.prop.link = "" THEN msg.disabled := FALSE END + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: Caption) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Caption).label := c.label$; + f(StdCFrames.Frame).Update + END Update; + + + (* Group *) + + PROCEDURE (c: Group) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, grpVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: Group) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(grpVersion) + END Externalize2; + + PROCEDURE (c: Group) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.Group; + BEGIN + f := StdCFrames.dir.NewGroup(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.label := c.label$; + frame := f + END GetNewFrame; + + PROCEDURE (c: Group) 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 (c: Group) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.SizePref DO + StdCFrames.dir.GetGroupSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard} + | msg: DefaultsPref DO + IF c.prop.link = "" THEN msg.disabled := FALSE END + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: Group) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Group).label := c.label$; + f(StdCFrames.Frame).Update + END Update; + + + (* TreeControl *) + + PROCEDURE (c: TreeControl) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, tfVersion, thisVersion) + END Internalize2; + + PROCEDURE (c: TreeControl) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(tfVersion) + END Externalize2; + + PROCEDURE TVNofNodesF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO par.l := rec.NofNodes() + ELSE par.l := 0 + END + END + END TVNofNodesF; + + PROCEDURE TVNofNodes (f: StdCFrames.TreeFrame): INTEGER; + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.l := 0; + IF c.item.Valid() THEN c.item.CallWith(TVNofNodesF, par) END; + RETURN par.l + END TVNofNodes; + + PROCEDURE TVChildF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO par.nodeOut := rec.Child(par.nodeIn, Dialog.firstPos) + ELSE par.nodeOut := NIL + END + END + END TVChildF; + + PROCEDURE TVChild (f: StdCFrames.TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.nodeIn := node; par.nodeOut := NIL; + IF c.item.Valid() THEN c.item.CallWith(TVChildF, par) END; + RETURN par.nodeOut + END TVChild; + + PROCEDURE TVParentF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO par.nodeOut := rec.Parent(par.nodeIn) + ELSE par.nodeOut := NIL + END + END + END TVParentF; + + PROCEDURE TVParent (f: StdCFrames.TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.nodeIn := node; par.nodeOut := NIL; + IF c.item.Valid() THEN c.item.CallWith(TVParentF, par) END; + RETURN par.nodeOut + END TVParent; + + PROCEDURE TVNextF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO par.nodeOut := rec.Next(par.nodeIn) + ELSE par.nodeOut := NIL + END + END + END TVNextF; + + PROCEDURE TVNext (f: StdCFrames.TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.nodeIn := node; par.nodeOut := NIL; + IF c.item.Valid() THEN c.item.CallWith(TVNextF, par) END; + RETURN par.nodeOut + END TVNext; + + PROCEDURE TVSelectF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO rec.Select(par.nodeIn) END + END + END TVSelectF; + + PROCEDURE TVSelect (f: StdCFrames.TreeFrame; node: Dialog.TreeNode); + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.nodeIn := node; + IF c.item.Valid() THEN + c.item.CallWith(TVSelectF, par); + Notify(c, f, Dialog.changed, 0, 0) + END + END TVSelect; + + PROCEDURE TVSelectedF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + WITH rec: Dialog.Tree DO par.nodeOut := rec.Selected() + ELSE par.nodeOut := NIL + END + END + END TVSelectedF; + + PROCEDURE TVSelected (f: StdCFrames.TreeFrame): Dialog.TreeNode; + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.nodeOut := NIL; + IF c.item.Valid() THEN c.item.CallWith(TVSelectedF, par) END; + RETURN par.nodeOut + END TVSelected; + + PROCEDURE TVSetExpansionF (VAR rec, par: ANYREC); + BEGIN + WITH par: TVParam DO + par.nodeIn.SetExpansion(par.e) + END + END TVSetExpansionF; + + PROCEDURE TVSetExpansion (f: StdCFrames.TreeFrame; tn: Dialog.TreeNode; expanded: BOOLEAN); + VAR c: TreeControl; par: TVParam; + BEGIN + c := f.view(TreeControl); par.e := expanded; par.nodeIn := tn; + IF c.item.Valid() THEN c.item.CallWith(TVSetExpansionF, par) END + END TVSetExpansion; + + PROCEDURE (c: TreeControl) GetNewFrame (VAR frame: Views.Frame); + VAR f: StdCFrames.TreeFrame; + BEGIN + f := StdCFrames.dir.NewTreeFrame(); + f.disabled := c.disabled; + f.undef := c.undef; + f.readOnly := c.readOnly; + f.font := c.font; + f.sorted := c.prop.opt[sorted]; + f.haslines := c.prop.opt[haslines]; + f.hasbuttons := c.prop.opt[hasbuttons]; + f.atroot := c.prop.opt[atroot]; + f.foldericons := c.prop.opt[foldericons]; + f.NofNodes := TVNofNodes; + f.Child := TVChild; + f.Parent := TVParent; + f.Next := TVNext; + f.Select := TVSelect; + f.Selected := TVSelected; + f.SetExpansion := TVSetExpansion; + frame := f + END GetNewFrame; + + PROCEDURE (c: TreeControl) UpdateList (f: Views.Frame); + BEGIN + f(StdCFrames.Frame).UpdateList() + END UpdateList; + + PROCEDURE (c: TreeControl) 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 (c: TreeControl) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH f: StdCFrames.TreeFrame DO + IF ~c.disabled & ~c.readOnly THEN + WITH msg: Controllers.EditMsg DO + IF (msg.op = Controllers.pasteChar) THEN + f.KeyDown(msg.char) + END + ELSE + CatchCtrlMsg(c, f, msg, focus) + END + ELSIF ~c.disabled THEN + WITH msg: Controllers.TrackMsg DO + f.MouseDown(msg.x, msg.y, msg.modifiers) + ELSE + END + END + END + END HandleCtrlMsg2; + + PROCEDURE (c: TreeControl) HandlePropMsg2 (VAR msg: Properties.Message); + BEGIN + WITH msg: Properties.ControlPref DO + IF (msg.char = lineChar) OR (msg.char = esc) THEN msg.accepts := FALSE END; + IF ~c.disabled & ~c.readOnly & IsShortcut(msg.char, c) OR msg.getFocus THEN + msg.getFocus := StdCFrames.setFocus + END + | msg: Properties.FocusPref DO + IF ~c.disabled & ~c.readOnly THEN + msg.setFocus := TRUE + ELSIF~c.disabled THEN + msg.hotFocus := TRUE + END + | msg: Properties.SizePref DO + StdCFrames.dir.GetTreeFrameSize(msg.w, msg.h) + | msg: PropPref DO + msg.valid := {link, label, guard, notifier, sorted, haslines, hasbuttons, atroot, foldericons} + | msg: Properties.ResizePref DO + msg.horFitToWin := TRUE; msg.verFitToWin := TRUE + ELSE + END + END HandlePropMsg2; + + PROCEDURE (c: TreeControl) CheckLink (VAR ok: BOOLEAN); + VAR name: Meta.Name; + BEGIN + GetTypeName(c.item, name); + ok := name = "Tree" + END CheckLink; + + PROCEDURE (c: TreeControl) Update (f: Views.Frame; op, from, to: INTEGER); + BEGIN + f(StdCFrames.Frame).Update + END Update; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) NewPushButton (p: Prop): Control; + VAR c: PushButton; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewPushButton; + + PROCEDURE (d: StdDirectory) NewCheckBox (p: Prop): Control; + VAR c: CheckBox; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewCheckBox; + + PROCEDURE (d: StdDirectory) NewRadioButton (p: Prop): Control; + VAR c: RadioButton; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewRadioButton; + + PROCEDURE (d: StdDirectory) NewField (p: Prop): Control; + VAR c: Field; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewField; + + PROCEDURE (d: StdDirectory) NewUpDownField (p: Prop): Control; + VAR c: UpDownField; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewUpDownField; + + PROCEDURE (d: StdDirectory) NewDateField (p: Prop): Control; + VAR c: DateField; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewDateField; + + PROCEDURE (d: StdDirectory) NewTimeField (p: Prop): Control; + VAR c: TimeField; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewTimeField; + + PROCEDURE (d: StdDirectory) NewColorField (p: Prop): Control; + VAR c: ColorField; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewColorField; + + PROCEDURE (d: StdDirectory) NewListBox (p: Prop): Control; + VAR c: ListBox; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewListBox; + + PROCEDURE (d: StdDirectory) NewSelectionBox (p: Prop): Control; + VAR c: SelectionBox; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewSelectionBox; + + PROCEDURE (d: StdDirectory) NewComboBox (p: Prop): Control; + VAR c: ComboBox; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewComboBox; + + PROCEDURE (d: StdDirectory) NewCaption (p: Prop): Control; + VAR c: Caption; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewCaption; + + PROCEDURE (d: StdDirectory) NewGroup (p: Prop): Control; + VAR c: Group; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewGroup; + + PROCEDURE (d: StdDirectory) NewTreeControl (p: Prop): Control; + VAR c: TreeControl; + BEGIN + NEW(c); OpenLink(c, p); RETURN c + END NewTreeControl; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); dir := d + END SetDir; + + PROCEDURE InitProp (VAR p: Prop); + BEGIN + NEW(p); + p.link := ""; p.label := ""; p.guard := ""; p.notifier := ""; + p.level := 0; + p.opt[0] := FALSE; p.opt[1] := FALSE; + p.opt[2] := FALSE; p.opt[3] := FALSE; + p.opt[4] := FALSE + END InitProp; + + PROCEDURE DepositPushButton*; + VAR p: Prop; + BEGIN + InitProp(p); + p.label := "#System:untitled"; + Views.Deposit(dir.NewPushButton(p)) + END DepositPushButton; + + PROCEDURE DepositCheckBox*; + VAR p: Prop; + BEGIN + InitProp(p); + p.label := "#System:untitled"; + Views.Deposit(dir.NewCheckBox(p)) + END DepositCheckBox; + + PROCEDURE DepositRadioButton*; + VAR p: Prop; + BEGIN + InitProp(p); + p.label := "#System:untitled"; + Views.Deposit(dir.NewRadioButton(p)) + END DepositRadioButton; + + PROCEDURE DepositField*; + VAR p: Prop; + BEGIN + InitProp(p); p.opt[left] := TRUE; + Views.Deposit(dir.NewField(p)) + END DepositField; + + PROCEDURE DepositUpDownField*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewUpDownField(p)) + END DepositUpDownField; + + PROCEDURE DepositDateField*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewDateField(p)) + END DepositDateField; + + PROCEDURE DepositTimeField*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewTimeField(p)) + END DepositTimeField; + + PROCEDURE DepositColorField*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewColorField(p)) + END DepositColorField; + + PROCEDURE DepositListBox*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewListBox(p)) + END DepositListBox; + + PROCEDURE DepositSelectionBox*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewSelectionBox(p)) + END DepositSelectionBox; + + PROCEDURE DepositComboBox*; + VAR p: Prop; + BEGIN + InitProp(p); + Views.Deposit(dir.NewComboBox(p)) + END DepositComboBox; + + PROCEDURE DepositCancelButton*; + VAR p: Prop; + BEGIN + InitProp(p); + p.link := "StdCmds.CloseDialog"; p.label := "#System:Cancel"; p.opt[cancel] := TRUE; + Views.Deposit(dir.NewPushButton(p)) + END DepositCancelButton; + + PROCEDURE DepositCaption*; + VAR p: Prop; + BEGIN + InitProp(p); p.opt[left] := TRUE; + p.label := "#System:Caption"; + Views.Deposit(dir.NewCaption(p)) + END DepositCaption; + + PROCEDURE DepositGroup*; + VAR p: Prop; + BEGIN + InitProp(p); + p.label := "#System:Caption"; + Views.Deposit(dir.NewGroup(p)) + END DepositGroup; + + PROCEDURE DepositTreeControl*; + VAR p: Prop; + BEGIN + InitProp(p); + p.opt[haslines] := TRUE; p.opt[hasbuttons] := TRUE; p.opt[atroot] := TRUE; p.opt[foldericons] := TRUE; + Views.Deposit(dir.NewTreeControl(p)) + END DepositTreeControl; + + PROCEDURE Relink*; + VAR msg: UpdateCachesMsg; + BEGIN + INC(stamp); + Views.Omnicast(msg) + END Relink; + + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + par := NIL; stamp := 0; + NEW(d); stdDir := d; dir := d; + NEW(cleaner); cleanerInstalled := 0 + END Init; + + + (* check guards action *) + + PROCEDURE (a: Action) Do; + VAR msg: Views.NotifyMsg; + BEGIN + IF Windows.dir # NIL THEN + IF a.w # NIL THEN + INC(a.cnt); + msg.id0 := 0; msg.id1 := 0; msg.opts := {guardCheck}; + IF a.w.seq # NIL THEN a.w.seq.Handle(msg) END; + a.w := Windows.dir.Next(a.w); + WHILE (a.w # NIL) & a.w.sub DO a.w := Windows.dir.Next(a.w) END + ELSE + IF a.cnt = 0 THEN a.resolution := Services.resolution + ELSE a.resolution := Services.resolution DIV a.cnt DIV 2 + END; + a.cnt := 0; + a.w := Windows.dir.First(); + WHILE (a.w # NIL) & a.w.sub DO a.w := Windows.dir.Next(a.w) END + END + END; + Services.DoLater(a, Services.Ticks() + a.resolution) + END Do; + +BEGIN + Init; + NEW(action); action.w := NIL; action.cnt := 0; Services.DoLater(action, Services.now) +CLOSE + Services.RemoveAction(action) +END Controls. diff --git a/Trurl-based/System/Mod/Converters.txt b/Trurl-based/System/Mod/Converters.txt new file mode 100644 index 0000000..1d1c557 --- /dev/null +++ b/Trurl-based/System/Mod/Converters.txt @@ -0,0 +1,105 @@ +MODULE Converters; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Converters.odc *) + (* DO NOT EDIT *) + + IMPORT Meta, Files, Stores, Dialog; + + CONST + (* hints *) + importAll* = 0; (* can import all file types *) + canceled = 8; + + TYPE + Importer* = PROCEDURE (f: Files.File; OUT s: Stores.Store); + Exporter* = PROCEDURE (s: Stores.Store; f: Files.File); + Converter* = POINTER TO RECORD + next-: Converter; + imp-, exp-: Dialog.String; + storeType-: Stores.TypeName; + fileType-: Files.Type; + opts-: SET + END; + + ImpVal = RECORD (Meta.Value) p: Importer END; + ExpVal = RECORD (Meta.Value) p: Exporter END; + + VAR + list-: Converter; + doc: Converter; + + PROCEDURE GetCommand (name: Dialog.String; VAR val: Meta.Value; VAR ok: BOOLEAN); + VAR i: Meta.Item; + BEGIN + Meta.LookupPath(name, i); + IF (i.obj = Meta.procObj) OR (i.obj = Meta.varObj) & (i.typ = Meta.procTyp) THEN + i.GetVal(val, ok) + ELSE ok := FALSE + END + END GetCommand; + + + PROCEDURE Register* (imp, exp: Dialog.String; storeType: Stores.TypeName; fileType: Files.Type; opts: SET); + VAR e, f: Converter; + BEGIN + ASSERT((imp # "") OR (exp # ""), 20); ASSERT(fileType # "", 21); + NEW(e); e.next := NIL; + e.imp := imp; e.exp := exp; e.fileType := fileType; e.storeType := storeType; e.opts := opts; + IF (storeType = "") & (doc = NIL) THEN doc := e END; + IF list = NIL THEN list := e + ELSE f := list; + WHILE f.next # NIL DO f := f.next END; + f.next := e + END + END Register; + + + PROCEDURE Import* (loc: Files.Locator; name: Files.Name; VAR conv: Converter; OUT s: Stores.Store); + VAR file: Files.File; val: ImpVal; ok: BOOLEAN; + BEGIN + ASSERT(loc # NIL, 20); ASSERT(name # "", 21); + file := Files.dir.Old(loc, name, Files.shared); s := NIL; + IF file # NIL THEN + IF conv = NIL THEN + conv := list; + WHILE (conv # NIL) & ((conv.fileType # file.type) OR (conv.imp = "")) DO conv := conv.next END; + IF conv = NIL THEN + conv := list; WHILE (conv # NIL) & ~(importAll IN conv.opts) DO conv := conv.next END + END + ELSE ASSERT(conv.imp # "", 22) + END; + IF conv # NIL THEN + GetCommand(conv.imp, val, ok); + IF ok THEN val.p(file, s) + ELSE Dialog.ShowMsg("#System:ConverterFailed") + END + ELSE Dialog.ShowMsg("#System:NoConverterFound") + END + END + END Import; + + PROCEDURE Export* (loc: Files.Locator; name: Files.Name; conv: Converter; s: Stores.Store); + VAR res: INTEGER; file: Files.File; val: ExpVal; ok: BOOLEAN; + BEGIN + ASSERT(s # NIL, 20); ASSERT(~(s IS Stores.Alien), 21); + ASSERT(loc # NIL, 22); ASSERT(name # "", 23); + file := Files.dir.New(loc, Files.ask); (* fileLoc := loc; *) + IF file # NIL THEN + IF conv = NIL THEN + conv := doc + ELSE ASSERT(conv.exp # "", 24) + END; + GetCommand(conv.exp, val, ok); + IF ok THEN + val.p(s, file); + IF loc.res # canceled THEN + file.Register(name, conv.fileType, Files.ask, res); loc.res := res + END + ELSE Dialog.ShowMsg("#System:ConverterFailed"); loc.res := canceled + END + END + END Export; + +BEGIN + list := NIL +END Converters. diff --git a/Trurl-based/System/Mod/Dates.txt b/Trurl-based/System/Mod/Dates.txt new file mode 100644 index 0000000..82a5552 --- /dev/null +++ b/Trurl-based/System/Mod/Dates.txt @@ -0,0 +1,191 @@ +MODULE Dates; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Dates.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel; + + CONST + monday* = 0; + tuesday* = 1; + wednesday* = 2; + thursday* = 3; + friday* = 4; + saturday* = 5; + sunday* = 6; + + short* = 0; + long* = 1; + abbreviated* = 2; + plainLong* = 3; + plainAbbreviated* = 4; + + TYPE + Date* = RECORD + year*, month*, day*: INTEGER + END; + + Time* = RECORD + hour*, minute*, second*: INTEGER + END; + + Hook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + VAR M, N: ARRAY 8 OF INTEGER; hook: Hook; + + PROCEDURE (h: Hook) GetTime* (OUT d: Date; OUT t: Time), NEW, ABSTRACT; + PROCEDURE (h: Hook) GetUTCTime* (OUT d: Date; OUT t: Time), NEW, ABSTRACT; + PROCEDURE (h: Hook) GetUTCBias* (OUT bias: INTEGER), NEW, ABSTRACT; + PROCEDURE (h: Hook) DateToString* (d: Date; format: INTEGER; OUT str: ARRAY OF CHAR), NEW, ABSTRACT; + PROCEDURE (h: Hook) TimeToString* (t: Time; OUT str: ARRAY OF CHAR), NEW, ABSTRACT; + + PROCEDURE SetHook* (h: Hook); + BEGIN + hook := h + END SetHook; + + PROCEDURE ValidTime* (IN t: Time): BOOLEAN; + BEGIN + RETURN + (t.hour >= 0) & (t.hour <= 23) + & (t.minute >= 0) & (t.minute <= 59) + & (t.second >= 0) & (t.second <= 59) + END ValidTime; + + PROCEDURE ValidDate* (IN d: Date): BOOLEAN; + VAR y, m, d1: INTEGER; + BEGIN + IF (d.year < 1) OR (d.year > 9999) OR (d.month < 1) OR (d.month > 12) OR (d.day < 1) THEN + RETURN FALSE + ELSE + y := d.year; m := d.month; + IF m = 2 THEN + IF (y < 1583) & (y MOD 4 = 0) + OR (y MOD 4 = 0) & ((y MOD 100 # 0) OR (y MOD 400 = 0)) THEN + d1 := 29 + ELSE d1 := 28 + END + ELSIF m IN {1, 3, 5, 7, 8, 10, 12} THEN d1 := 31 + ELSE d1 := 30 + END; + IF (y = 1582) & (m = 10) & (d.day > 4) & (d.day < 15) THEN RETURN FALSE END; + RETURN d.day <= d1 + END + END ValidDate; + + PROCEDURE Day* (IN d: Date): INTEGER; + VAR y, m, n: INTEGER; + BEGIN + y := d.year; m := d.month - 3; + IF m < 0 THEN INC(m, 12); DEC(y) END; + n := y * 1461 DIV 4 + (m * 153 + 2) DIV 5 + d.day - 306; + IF n > 577737 THEN n := n - (y DIV 100 * 3 - 5) DIV 4 END; + RETURN n + END Day; + + PROCEDURE DayToDate* (n: INTEGER; OUT d: Date); + VAR c, y, m: INTEGER; + BEGIN + IF n > 577737 THEN + n := n * 4 + 1215; c := n DIV 146097; n := n MOD 146097 DIV 4 + ELSE + n := n + 305; c := 0 + END; + n := n * 4 + 3; y := n DIV 1461; n := n MOD 1461 DIV 4; + n := n * 5 + 2; m := n DIV 153; n := n MOD 153 DIV 5; + IF m > 9 THEN m := m - 12; INC(y) END; + d.year := SHORT(100 * c + y); + d.month := SHORT(m + 3); + d.day := SHORT(n + 1) + END DayToDate; + + PROCEDURE GetDate* (OUT d: Date); + VAR t: Time; + BEGIN + ASSERT(hook # NIL, 100); + hook.GetTime(d, t) + END GetDate; + + PROCEDURE GetTime* (OUT t: Time); + VAR d: Date; + BEGIN + ASSERT(hook # NIL, 100); + hook.GetTime(d, t) + END GetTime; + + (* UTC = Coordinated Universal Time, also konown as Greenwich Mean time (GMT). *) + + PROCEDURE GetUTCDate* (OUT d: Date); + VAR t: Time; + BEGIN + ASSERT(hook # NIL, 100); + hook.GetUTCTime(d, t) + END GetUTCDate; + + PROCEDURE GetUTCTime* (OUT t: Time); + VAR d: Date; + BEGIN + ASSERT(hook # NIL, 100); + hook.GetUTCTime(d, t) + END GetUTCTime; + + PROCEDURE GetUTCBias* (OUT bias: INTEGER); + (* + Returns the current bias, in minutes, for local time translation on this computer. The bias is the difference, + in minutes, between Coordinated Universal Time (UTC) and local time. All translations between UTC and + local time are based on the following formula: + UTC = local time + bias + *) + BEGIN + ASSERT(hook # NIL, 100); + hook.GetUTCBias(bias) + END GetUTCBias; + + + PROCEDURE GetEasterDate* (year: INTEGER; OUT d: Date); + VAR k, m, n, a, b, c, d0, e, o: INTEGER; month, day: INTEGER; + BEGIN + ASSERT((year >= 1583) & (year <= 2299), 20); + k := year DIV 100 - 15; + m := M[k]; n := N[k]; + a := year MOD 19; b := year MOD 4; c := year MOD 7; + d0 := (19*a + m) MOD 30; e := (2*b+4*c+6*d0+n) MOD 7; + o := 21+d0+e; month := 3+o DIV 31; day := o MOD 31+1; + IF month = 4 THEN + IF day = 26 THEN day := 19 + ELSIF (day = 25) & (d0=28) & (e = 6) & (a > 10) THEN day := 18 + END + END; + d.year := year; + d.month := month; + d.day := day + END GetEasterDate; + + PROCEDURE DayOfWeek* (IN d: Date): INTEGER; + (** post: res = 0: Monday .. res = 6: Sunday **) + BEGIN + RETURN SHORT((4+Day(d)) MOD 7) + END DayOfWeek; + + PROCEDURE DateToString* (IN d: Date; format: INTEGER; OUT str: ARRAY OF CHAR); + BEGIN + ASSERT(hook # NIL, 100); + hook.DateToString(d, format, str) + END DateToString; + + PROCEDURE TimeToString* (IN t: Time; OUT str: ARRAY OF CHAR); + BEGIN + ASSERT(hook # NIL, 100); + hook.TimeToString(t, str) + END TimeToString; + +BEGIN + M[0] := 22; N[0] := 2; + M[1] := 22; N[1] := 2; + M[2] := 23; N[2] := 3; + M[3] := 23; N[3] := 4; + M[4] := 24; N[4] := 5; + M[5] := 24; N[5] := 5; + M[6] := 24; N[6] := 6; + M[7] := 25; N[7] := 0; +END Dates. diff --git a/Trurl-based/System/Mod/Dialog.txt b/Trurl-based/System/Mod/Dialog.txt new file mode 100644 index 0000000..7726be1 --- /dev/null +++ b/Trurl-based/System/Mod/Dialog.txt @@ -0,0 +1,1202 @@ +MODULE Dialog; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Dialog.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel, Files; + + CONST + pressed* = 1; released* = 2; changed* = 3; included* = 5; excluded* = 6; set* = 7; (** notify ops **) + ok* = 1; yes* = 2; no* = 3; cancel* = 4; (** GetOK forms & results **) + persistent* = TRUE; nonPersistent* = FALSE; (** constants for SetLanguage **) + + stringLen = 256; + bufLen = 252; + + rsrcDir = "Rsrc"; + stringFile = "Strings"; + TAB = 09X; CR = 0DX; + update = 2; (* notify options *) + listUpdate = 3; + guardCheck = 4; + + windows32s* = 11; + windows95* = 12; + windowsNT3* = 13; + windowsNT4* = 14; + windows2000* = 15; + windows98* = 16; + windowsXP* = 17; + windowsVista* = 18; + macOS* = 21; + macOSX* = 22; + linux* = 30; + tru64* = 40; + + firstPos* = 0; + lastPos* = -1; + + TYPE + String* = ARRAY stringLen OF CHAR; + + Buf = POINTER TO RECORD + next: Buf; + s: ARRAY bufLen OF CHAR + END; + + StrList = RECORD + len, max: INTEGER; (* number of items, max number of items *) + strings: Buf; (* string buffer list. strings[0] = 0X -> uninitialized items appear as empty *) + end: INTEGER; (* next free position in string buffer list *) + scnt: INTEGER; (* number of strings in list, including unused entries *) + items: POINTER TO ARRAY OF INTEGER (* indices into string buffer list *) + END; + + List* = RECORD + index*: INTEGER; (** val IN [0, n-1] **) + len-: INTEGER; + l: StrList + END; + + Combo* = RECORD + item*: String; + len-: INTEGER; + l: StrList + END; + + Selection* = RECORD + len-: INTEGER; + sel: POINTER TO ARRAY OF SET; + l: StrList + END; + + Currency* = RECORD (* number = val * 10^-scale *) + val*: LONGINT; + scale*: INTEGER + END; + + Color* = RECORD + val*: INTEGER + END; + + TreeNode* = POINTER TO LIMITED RECORD + nofChildren: INTEGER; + name: String; + parent, next, prev, firstChild: TreeNode; + viewAsFolder, expanded: BOOLEAN; + data: ANYPTR; + tree: INTEGER + END; + + Tree* = RECORD + nofRoots, nofNodes: INTEGER; + firstRoot, selected: TreeNode + END; + + (** command procedure types**) + + Par* = RECORD (** parameter for guard procedures **) + disabled*: BOOLEAN; (** OUT, preset to FALSE **) + checked*: BOOLEAN; (** OUT, preset to default **) + undef*: BOOLEAN; (** OUT, preset to default **) + readOnly*: BOOLEAN; (** OUT, preset to default **) + label*: String (** OUT, preset to "" **) + END; + + GuardProc* = PROCEDURE (VAR par: Par); + NotifierProc* = PROCEDURE (op, from, to: INTEGER); + + StringPtr = POINTER TO ARRAY [untagged] OF CHAR; + StringTab = POINTER TO RECORD + next: StringTab; + name: Files.Name; + key: POINTER TO ARRAY OF StringPtr; + str: POINTER TO ARRAY OF StringPtr; + data: POINTER TO ARRAY OF CHAR + END; + + LangNotifier* = POINTER TO ABSTRACT RECORD next: LangNotifier END; + Language* = ARRAY 3 OF CHAR; + + LangTrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + + GetHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + ShowHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + CallHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + NotifyHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + LanguageHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + VAR + metricSystem*: BOOLEAN; + showsStatus*: BOOLEAN; + platform*: INTEGER; + commandLinePars*: String; + version*: INTEGER; + appName*: ARRAY 32 OF CHAR; + language-: Language; + user*: ARRAY 32 OF CHAR; + caretPeriod*: INTEGER; + thickCaret*: BOOLEAN; + + tabList: StringTab; + langNotifiers: LangNotifier; + currentNotifier: LangNotifier; + + gethook: GetHook; + showHook: ShowHook; + callHook: CallHook; + notifyHook: NotifyHook; + languageHook: LanguageHook; + + PROCEDURE (h: GetHook) GetOK* (IN str, p0, p1, p2: ARRAY OF CHAR; form: SET; + OUT res: INTEGER), NEW, ABSTRACT; + PROCEDURE (h: GetHook) GetColor* (in: INTEGER; OUT out: INTEGER; + OUT set: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (h: GetHook) GetIntSpec* (IN defType: Files.Type; VAR loc: Files.Locator; + OUT name: Files.Name), NEW, ABSTRACT; + PROCEDURE (h: GetHook) GetExtSpec* (IN defName: Files.Name; IN defType: Files.Type; + VAR loc: Files.Locator; OUT name: Files.Name), NEW, ABSTRACT; + + PROCEDURE SetGetHook*(h: GetHook); + BEGIN + gethook := h + END SetGetHook; + + PROCEDURE (h: ShowHook) ShowParamMsg* (IN str, p0, p1, p2: ARRAY OF CHAR), NEW, ABSTRACT; + PROCEDURE (h: ShowHook) ShowParamStatus* (IN str, p0, p1, p2: ARRAY OF CHAR), NEW, ABSTRACT; + + PROCEDURE SetShowHook* (h: ShowHook); + BEGIN + showHook := h + END SetShowHook; + + PROCEDURE (h: CallHook) Call* (IN proc, errorMsg: ARRAY OF CHAR; VAR res: INTEGER), NEW, ABSTRACT; + + PROCEDURE SetCallHook* (h: CallHook); + BEGIN + callHook := h + END SetCallHook; + + PROCEDURE (h: NotifyHook) Notify* (id0, id1: INTEGER; opts: SET), NEW, ABSTRACT; + + PROCEDURE SetNotifyHook* (h: NotifyHook); + BEGIN + notifyHook := h + END SetNotifyHook; + + PROCEDURE (h: LanguageHook) SetLanguage* (lang: Language; persistent: BOOLEAN; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (h: LanguageHook) GetPersistentLanguage* (OUT lang: Language), NEW, ABSTRACT; + + PROCEDURE SetLanguageHook* (h: LanguageHook); + BEGIN + languageHook := h + END SetLanguageHook; + + PROCEDURE ReadStringFile (subsys: Files.Name; f: Files.File; VAR tab: StringTab); + VAR i, j, h, n, s, x, len, next, down, end: INTEGER; in, in1: Files.Reader; + ch: CHAR; b: BYTE; p, q: StringPtr; + + PROCEDURE ReadInt (OUT x: INTEGER); + VAR b: BYTE; + BEGIN + in.ReadByte(b); x := b MOD 256; + in.ReadByte(b); x := x + (b MOD 256) * 100H; + in.ReadByte(b); x := x + (b MOD 256) * 10000H; + in.ReadByte(b); x := x + b * 1000000H + END ReadInt; + + PROCEDURE ReadHead (OUT next, down, end: INTEGER); + VAR b, t: BYTE; n: INTEGER; + BEGIN + in.ReadByte(b); + REPEAT + in.ReadByte(t); + IF t = -14 THEN ReadInt(n) + ELSE + REPEAT in.ReadByte(b) UNTIL b = 0 + END + UNTIL t # -15; + ReadInt(n); + ReadInt(next); next := next + in.Pos(); + ReadInt(down); down := down + in.Pos(); + ReadInt(end); end := end + in.Pos() + END ReadHead; + + BEGIN + tab := NIL; + IF f # NIL THEN (* read text file *) + in := f.NewReader(NIL); in1 := f.NewReader(NIL); + IF (in # NIL) & (in1 # NIL) THEN + in.SetPos(8); ReadHead(next, down, end); (* document view *) + in.SetPos(down); ReadHead(next, down, end); (* document model *) + in.SetPos(down); ReadHead(next, down, end); (* text view *) + in.SetPos(down); ReadHead(next, down, end); (* text model *) + in.ReadByte(b); in.ReadByte(b); in.ReadByte(b); (* versions *) + in.ReadByte(b); in.ReadByte(b); in.ReadByte(b); + ReadInt(x); in1.SetPos(in.Pos() + x); (* text offset *) + next := down; + NEW(tab); tab.name := subsys$; + NEW(tab.data, f.Length()); + n := 0; i := 0; s := 0; in.ReadByte(b); + WHILE b # -1 DO + IF next = in.Pos() THEN ReadHead(next, down, end); in.SetPos(end) END; (* skip attributes *) + ReadInt(len); + IF len > 0 THEN (* shortchar run *) + WHILE len > 0 DO + in1.ReadByte(b); ch := CHR(b MOD 256); + IF ch >= " " THEN + IF s = 0 THEN j := i; s := 1 END; (* start of left part *) + tab.data[j] := ch; INC(j) + ELSIF (s = 1) & (ch = TAB) THEN + tab.data[j] := 0X; INC(j); + s := 2 (* start of right part *) + ELSIF (s = 2) & (ch = CR) THEN + tab.data[j] := 0X; INC(j); + INC(n); i := j; s := 0 (* end of line *) + ELSE + s := 0 (* reset *) + END; + DEC(len) + END + ELSIF len < 0 THEN (* longchar run *) + WHILE len < 0 DO + in1.ReadByte(b); x := b MOD 256; in1.ReadByte(b); ch := CHR(x + 256 * (b + 128)); + IF s = 0 THEN j := i; s := 1 END; (* start of left part *) + tab.data[j] := ch; INC(j); + INC(len, 2) + END + ELSE (* view *) + ReadInt(x); ReadInt(x); in1.ReadByte(b); (* ignore *) + END; + IF next = in.Pos() THEN ReadHead(next, down, end); in.SetPos(end) END; (* skip view data *) + in.ReadByte(b); + END; + IF n > 0 THEN + NEW(tab.key, n); NEW(tab.str, n); i := 0; j := 0; + WHILE j < n DO + tab.key[j] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[i])); + WHILE tab.data[i] >= " " DO INC(i) END; + INC(i); + tab.str[j] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[i])); + WHILE tab.data[i] >= " " DO INC(i) END; + INC(i); INC(j) + END; + (* sort keys (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > n; + REPEAT h := h DIV 3; i := h; + WHILE i < n DO p := tab.key[i]; q := tab.str[i]; j := i; + WHILE (j >= h) & (tab.key[j-h]^ > p^) DO + tab.key[j] := tab.key[j-h]; tab.str[j] := tab.str[j-h]; j := j-h + END; + tab.key[j] := p; tab.str[j] := q; INC(i) + END + UNTIL h = 1 + END + END + END + END ReadStringFile; + + PROCEDURE MergeTabs (VAR master, extra: StringTab): StringTab; + VAR tab: StringTab; nofKeys, datalength, di, mi, ei, ml, el, ti, i: INTEGER; + BEGIN + IF (extra = NIL) OR (extra.key = NIL) THEN RETURN master END; + IF (master = NIL) OR (master.key = NIL) THEN RETURN extra END; + ml := LEN(master.key); el := LEN(extra.key); + mi := 0; ei := 0; datalength := 0; nofKeys := 0; + (* find out how big the resulting table will be *) + WHILE (mi < ml) OR (ei < el) DO + INC(nofKeys); + IF (mi < ml) & (ei < el) & (master.key[mi]$ = extra.key[ei]$) THEN + datalength := datalength + LEN(master.key[mi]$) + LEN(master.str[mi]$) + 2; INC(mi); INC(ei) + ELSIF (ei < el) & ((mi >= ml) OR (master.key[mi]$ > extra.key[ei]$)) THEN + datalength := datalength + LEN(extra.key[ei]$) + LEN(extra.str[ei]$) + 2; INC(ei) + ELSE + datalength := datalength + LEN(master.key[mi]$) + LEN(master.str[mi]$) + 2; INC(mi) + END + END; + NEW(tab); tab.name := master.name; + NEW(tab.key, nofKeys); NEW(tab.str, nofKeys); NEW(tab.data, datalength); + mi := 0; ei := 0; di := 0; ti := 0; + (* do the merge *) + WHILE (mi < ml) OR (ei < el) DO + IF (mi < ml) & (ei < el) & (master.key[mi]$ = extra.key[ei]$) THEN + i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE master.key[mi][i] # 0X DO tab.data[di] := master.key[mi][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); i := 0; + tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE master.str[mi][i] # 0X DO tab.data[di] := master.str[mi][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); + INC(mi); INC(ei) + ELSIF (ei < el) & ((mi >= ml) OR (master.key[mi]$ > extra.key[ei]$)) THEN + i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE extra.key[ei][i] # 0X DO tab.data[di] := extra.key[ei][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); i := 0; + tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE extra.str[ei][i] # 0X DO tab.data[di] := extra.str[ei][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); + INC(ei) + ELSE + i := 0; tab.key[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE master.key[mi][i] # 0X DO tab.data[di] := master.key[mi][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); i := 0; + tab.str[ti] := SYSTEM.VAL(StringPtr, SYSTEM.ADR(tab.data[di])); + WHILE master.str[mi][i] # 0X DO tab.data[di] := master.str[mi][i]; INC(di); INC(i) END; + tab.data[di] :=0X; INC(di); + INC(mi) + END; + INC(ti) + END; + RETURN tab + END MergeTabs; + + PROCEDURE LoadStringTab (subsys: Files.Name; VAR tab: StringTab); + VAR loc: Files.Locator; f: Files.File; name: Files.Name; ltab: StringTab; + BEGIN + tab := NIL; + name := stringFile; Kernel.MakeFileName(name, ""); + loc := Files.dir.This(subsys); loc := loc.This(rsrcDir); + IF loc # NIL THEN + f := Files.dir.Old(loc, name, Files.shared); + ReadStringFile(subsys, f, tab); + IF language # "" THEN + loc := loc.This(language); + IF loc # NIL THEN + f := Files.dir.Old(loc, name, Files.shared); + ReadStringFile(subsys, f, ltab); + tab := MergeTabs(ltab, tab) + END + END; + IF tab # NIL THEN tab.next := tabList; tabList := tab END + END + END LoadStringTab; + + PROCEDURE SearchString (VAR in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + VAR i, j, k, len: INTEGER; ch: CHAR; subsys: Files.Name; tab: StringTab; + BEGIN + out := ""; + IF in[0] = "#" THEN + i := 0; ch := in[1]; + WHILE (ch # 0X) (* & (ch # ".") *) & (ch # ":") DO subsys[i] := ch; INC(i); ch := in[i + 1] END; + subsys[i] := 0X; + IF ch # 0X THEN + INC(i, 2); ch := in[i]; j := 0; + WHILE (ch # 0X) DO in[j] := ch; INC(i); INC(j); ch := in[i] END; + in[j] := 0X + ELSE + RETURN + END; + tab := tabList; + WHILE (tab # NIL) & (tab.name # subsys) DO tab := tab.next END; + IF tab = NIL THEN LoadStringTab(subsys, tab) END; + IF tab # NIL THEN + i := 0; + IF tab.key = NIL THEN j := 0 ELSE j := LEN(tab.key^) END; + WHILE i < j DO (* binary search *) + k := (i + j) DIV 2; + IF tab.key[k]^ < in THEN i := k + 1 ELSE j := k END + END; + IF (tab.key # NIL) & (j < LEN(tab.key^)) & (tab.key[j]^ = in) THEN + k := 0; len := LEN(out)-1; + WHILE (k < len) & (tab.str[j][k] # 0X) DO + out[k] := tab.str[j][k]; INC(k) + END; + out[k] := 0X + END + END + END + END SearchString; + + + PROCEDURE Init (VAR l: StrList); + BEGIN + l.len := 0; l.max := 0; l.end := 0; l.scnt := 0 + END Init; + + PROCEDURE Compact (VAR l: StrList); + VAR i, j, k: INTEGER; ibuf, jbuf: Buf; ch: CHAR; + BEGIN + i := 1; ibuf := l.strings; j := 1; jbuf := l.strings; + WHILE j < l.end DO + (* find index entry k pointing to position j *) + k := 0; WHILE (k < l.len) & (l.items[k] # j) DO INC(k) END; + IF k < l.len THEN (* copy string *) + l.items[k] := i; + REPEAT + ch := jbuf.s[j MOD bufLen]; INC(j); + IF j MOD bufLen = 0 THEN jbuf := jbuf.next END; + ibuf.s[i MOD bufLen] := ch; INC(i); + IF i MOD bufLen = 0 THEN ibuf := ibuf.next END + UNTIL ch = 0X + ELSE (* skip next string *) + REPEAT + ch := jbuf.s[j MOD bufLen]; INC(j); + IF j MOD bufLen = 0 THEN jbuf := jbuf.next END + UNTIL ch = 0X + END + END; + ibuf.next := NIL; (* release superfluous buffers *) + l.end := i; l.scnt := l.len + END Compact; + + PROCEDURE SetLen (VAR l: StrList; len: INTEGER); + CONST D = 32; + VAR i, newmax: INTEGER; + items: POINTER TO ARRAY OF INTEGER; + BEGIN + IF l.items = NIL THEN Init(l) END; + IF (l.max - D < len) & (len <= l.max) THEN + (* we do not reallocate anything *) + ELSE + newmax := (len + D-1) DIV D * D; + IF newmax > 0 THEN + IF l.strings = NIL THEN NEW(l.strings); (* l.strings[0] := 0X; *) l.end := 1 END; + NEW(items, newmax); + IF len < l.len THEN i := len ELSE i := l.len END; + WHILE i > 0 DO DEC(i); items[i] := l.items[i] END; + l.items := items + END; + l.max := newmax + END; + l.len := len; + IF (l.scnt > 32) & (l.scnt > 2 * l.len) THEN Compact(l) END + END SetLen; + + PROCEDURE GetItem (VAR l: StrList; index: INTEGER; VAR item: String); + VAR i, j, k: INTEGER; b: Buf; ch: CHAR; + BEGIN + IF l.items = NIL THEN Init(l) END; + IF (index >= 0) & (index < l.len) THEN + i := l.items[index]; j := i MOD bufLen; i := i DIV bufLen; + b := l.strings; WHILE i # 0 DO b := b.next; DEC(i) END; + k := 0; + REPEAT + ch := b.s[j]; INC(j); IF j = bufLen THEN j := 0; b := b.next END; + item[k] := ch; INC(k) + UNTIL ch = 0X + ELSE + item := "" + END + END GetItem; + + PROCEDURE SetItem (VAR l: StrList; index: INTEGER; item: ARRAY OF CHAR); + VAR len, i, j, k: INTEGER; b: Buf; ch: CHAR; + BEGIN + IF l.items = NIL THEN Init(l) END; + IF index >= l.len THEN SetLen(l, index + 1) END; + IF (l.scnt > 32) & (l.scnt > 2 * l.len) THEN Compact(l) END; + len := 0; WHILE item[len] # 0X DO INC(len) END; + IF len >= stringLen THEN len := stringLen - 1; item[len] := 0X END; (* clip long strings *) + l.items[index] := l.end; + i := l.end; j := i MOD bufLen; i := i DIV bufLen; + b := l.strings; WHILE i # 0 DO b := b.next; DEC(i) END; + k := 0; + REPEAT + ch := item[k]; INC(k); INC(l.end); + b.s[j] := ch; INC(j); IF j = bufLen THEN j := 0; NEW(b.next); b := b.next END + UNTIL ch = 0X; + INC(l.scnt) + END SetItem; + + PROCEDURE SetResources (VAR l: StrList; IN key: ARRAY OF CHAR); + VAR i, k, j, x: INTEGER; ch: CHAR; s, a: ARRAY 16 OF CHAR; h, item: ARRAY 256 OF CHAR; + BEGIN + IF l.items = NIL THEN Init(l) END; + i := 0; + REPEAT + x := i; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0; + k := 0; REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X; + h := key + "[" + s + "]"; + SearchString(h, item); + IF item # "" THEN SetItem(l, i, item) END; + INC(i) + UNTIL item = "" + END SetResources; + + + (** List **) + + PROCEDURE (VAR l: List) SetLen* (len: INTEGER), NEW; + BEGIN + ASSERT(len >= 0, 20); + SetLen(l.l, len); + l.len := l.l.len + END SetLen; + + PROCEDURE (VAR l: List) GetItem* (index: INTEGER; OUT item: String), NEW; + BEGIN + GetItem(l.l, index, item); + l.len := l.l.len + END GetItem; + + PROCEDURE (VAR l: List) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(index >= 0, 20); ASSERT(item # "", 21); + SetItem(l.l, index, item); + l.len := l.l.len + END SetItem; + + PROCEDURE (VAR l: List) SetResources* (IN key: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(key # "", 20); + SetResources(l.l, key); + l.len := l.l.len + END SetResources; + + + (** Selection **) + + PROCEDURE (VAR s: Selection) SetLen* (len: INTEGER), NEW; + VAR sel: POINTER TO ARRAY OF SET; i: INTEGER; + BEGIN + ASSERT(len >= 0, 20); + SetLen(s.l, len); + len := len + (MAX(SET) - 1) DIV MAX(SET); + IF len = 0 THEN s.sel := NIL + ELSIF s.sel = NIL THEN NEW(s.sel, len) + ELSIF LEN(s.sel^) # len THEN + NEW(sel, len); + IF LEN(s.sel^) < len THEN len := LEN(s.sel^) END; + i := 0; WHILE i < len DO sel[i] := s.sel[i]; INC(i) END; + s.sel := sel + END; + s.len := s.l.len + END SetLen; + + PROCEDURE (VAR s: Selection) GetItem* (index: INTEGER; OUT item: String), NEW; + BEGIN + GetItem(s.l, index, item); + s.len := s.l.len + END GetItem; + + PROCEDURE (VAR s: Selection) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(index >= 0, 20); (*ASSERT(index < s.l.len, 21);*) ASSERT(item # "", 21); + SetItem(s.l, index, item); + IF s.l.len > s.len THEN s.SetLen(s.l.len) END + END SetItem; + + PROCEDURE (VAR s: Selection) SetResources* (IN key: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(key # "", 20); + SetResources(s.l, key); + IF s.l.len > s.len THEN s.SetLen(s.l.len) END + END SetResources; + + PROCEDURE (VAR s: Selection) In* (index: INTEGER): BOOLEAN, NEW; + BEGIN + IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END; + IF s.sel # NIL THEN RETURN (index MOD 32) IN (s.sel[index DIV 32]) ELSE RETURN FALSE END + END In; + + PROCEDURE (VAR s: Selection) Excl* (from, to: INTEGER), NEW; + BEGIN + IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END; + IF from < 0 THEN from := 0 END; + IF to >= s.l.len THEN to := s.l.len - 1 END; + WHILE from <= to DO EXCL(s.sel[from DIV 32], from MOD 32); INC(from) END + END Excl; + + PROCEDURE (VAR s: Selection) Incl* (from, to: INTEGER), NEW; + BEGIN + IF s.l.items = NIL THEN Init(s.l); s.len := s.l.len END; + IF from < 0 THEN from := 0 END; + IF to >= s.l.len THEN to := s.l.len - 1 END; + WHILE from <= to DO INCL(s.sel[from DIV 32], from MOD 32); INC(from) END + END Incl; + + + (** Combo **) + + PROCEDURE (VAR c: Combo) SetLen* (len: INTEGER), NEW; + BEGIN + ASSERT(len >= 0, 20); + SetLen(c.l, len); + c.len := c.l.len + END SetLen; + + PROCEDURE (VAR c: Combo) GetItem* (index: INTEGER; OUT item: String), NEW; + BEGIN + GetItem(c.l, index, item); + c.len := c.l.len + END GetItem; + + PROCEDURE (VAR c: Combo) SetItem* (index: INTEGER; IN item: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(index >= 0, 20); ASSERT(item # "", 21); + SetItem(c.l, index, item); + c.len := c.l.len + END SetItem; + + PROCEDURE (VAR c: Combo) SetResources* (IN key: ARRAY OF CHAR), NEW; + BEGIN + ASSERT(key # "", 20); + SetResources(c.l, key); + c.len := c.l.len + END SetResources; + + + (* Tree and TreeNode *) + + PROCEDURE (tn: TreeNode) SetName* (name: String), NEW; + BEGIN + tn.name := name + END SetName; + + PROCEDURE (tn: TreeNode) GetName* (OUT name: String), NEW; + BEGIN + name := tn.name + END GetName; + + PROCEDURE (tn: TreeNode) SetData* (data: ANYPTR), NEW; + BEGIN + tn.data := data + END SetData; + + PROCEDURE (tn: TreeNode) Data* (): ANYPTR, NEW; + BEGIN + RETURN tn.data + END Data; + + PROCEDURE (tn: TreeNode) NofChildren* (): INTEGER, NEW; + BEGIN + RETURN tn.nofChildren + END NofChildren; + + PROCEDURE (tn: TreeNode) SetExpansion* (expanded: BOOLEAN), NEW; + BEGIN + tn.expanded := expanded + END SetExpansion; + + PROCEDURE (tn: TreeNode) IsExpanded* (): BOOLEAN, NEW; + BEGIN + RETURN tn.expanded + END IsExpanded; + + PROCEDURE (tn: TreeNode) IsFolder* (): BOOLEAN, NEW; + BEGIN + IF (~tn.viewAsFolder) & (tn.firstChild = NIL) THEN + RETURN FALSE + ELSE + RETURN TRUE + END + END IsFolder; + + PROCEDURE (tn: TreeNode) ViewAsFolder* (isFolder: BOOLEAN), NEW; + BEGIN + tn.viewAsFolder := isFolder + END ViewAsFolder; + + PROCEDURE (VAR t: Tree) NofNodes* (): INTEGER, NEW; + BEGIN + IF t.firstRoot = NIL THEN + RETURN 0 + ELSE + RETURN MAX(0, t.nofNodes) + END + END NofNodes; + + PROCEDURE (VAR t: Tree) NofRoots* (): INTEGER, NEW; + BEGIN + IF t.firstRoot = NIL THEN + RETURN 0 + ELSE + RETURN MAX(0, t.nofRoots) + END + END NofRoots; + + PROCEDURE (VAR t: Tree) Parent* (node: TreeNode): TreeNode, NEW; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21); + RETURN node.parent + END Parent; + + PROCEDURE (VAR t: Tree) Next* (node: TreeNode): TreeNode, NEW; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21); + RETURN node.next + END Next; + + PROCEDURE (VAR t: Tree) Prev* (node: TreeNode): TreeNode, NEW; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21); + RETURN node.prev + END Prev; + + PROCEDURE (VAR t: Tree) Child* (node: TreeNode; pos: INTEGER): TreeNode, NEW; + VAR cur: TreeNode; + BEGIN + ASSERT(pos >= lastPos, 20); ASSERT((node = NIL) OR (node.tree = SYSTEM.ADR(t)), 21); + IF node = NIL THEN cur := t.firstRoot + ELSE cur := node.firstChild END; + IF pos = lastPos THEN + WHILE (cur # NIL) & (cur.next # NIL) DO cur := cur.next END + ELSE + WHILE (cur # NIL) & (pos > 0) DO cur := cur.next; DEC(pos) END + END; + RETURN cur + END Child; + + PROCEDURE (VAR t: Tree) Selected* (): TreeNode, NEW; + BEGIN + RETURN t.selected + END Selected; + + PROCEDURE (VAR t: Tree) Select* (node: TreeNode), NEW; + BEGIN + ASSERT((node = NIL) OR (node.tree = SYSTEM.ADR(t)), 20); + IF (node # NIL) OR (t.nofRoots = 0) THEN + t.selected := node + ELSE + t.selected := t.Child(NIL, 0) + END + END Select; + + PROCEDURE Include (IN t: Tree; node: TreeNode); + VAR c: TreeNode; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = 0, 100); + node.tree := SYSTEM.ADR(t); + c := node.firstChild; + WHILE c # NIL DO Include(t, c); c := c.next END + END Include; + + PROCEDURE (VAR t: Tree) InsertAt (parent: TreeNode; pos: INTEGER; node: TreeNode), NEW; + VAR + cur, prev: TreeNode; + BEGIN + ASSERT(node # NIL, 20); ASSERT(pos >= lastPos, 21); + ASSERT((parent = NIL) OR (parent.tree = SYSTEM.ADR(t)), 22); ASSERT(node.tree = 0, 23); + Include(t, node); + IF parent = NIL THEN (* Add new root *) + IF (t.firstRoot = NIL) OR (pos = 0) THEN + node.next := t.firstRoot; node.prev := NIL; + IF t.firstRoot # NIL THEN t.firstRoot.prev := node END; + t.firstRoot := node + ELSE + cur := t.firstRoot; + IF pos = lastPos THEN pos := t.nofRoots END; + WHILE (cur # NIL) & (pos > 0) DO + prev := cur; cur := t.Next(cur); DEC(pos) + END; + IF cur = NIL THEN + prev.next := node; node.prev := prev + ELSE + node.next := cur; node.prev := cur.prev; cur.prev := node; prev.next := node + END + END; + INC(t.nofRoots) + ELSE (* Add child *) + IF pos = lastPos THEN pos := parent.nofChildren END; + IF (parent.firstChild = NIL) OR (pos = 0) THEN + IF parent.firstChild # NIL THEN parent.firstChild.prev := node END; + node.prev := NIL; node.next := parent.firstChild; parent.firstChild := node + ELSE + cur := parent.firstChild; + WHILE (cur # NIL) & (pos > 0) DO + prev := cur; cur := t.Next(cur); DEC(pos) + END; + IF cur = NIL THEN + prev.next := node; node.prev := prev + ELSE + node.next := cur; node.prev := cur.prev; cur.prev := node; prev.next := node + END + END; + INC(parent.nofChildren) + END; + node.parent := parent; + INC(t.nofNodes) + END InsertAt; + + PROCEDURE (VAR t: Tree) NewChild* (parent: TreeNode; pos: INTEGER; name: String): TreeNode, NEW; + VAR + new: TreeNode; + BEGIN + NEW(new); new.tree := 0; + new.SetName(name); new.expanded := FALSE; new.nofChildren := 0; + new.viewAsFolder := FALSE; + t.InsertAt(parent, pos, new); + RETURN new + END NewChild; + + PROCEDURE (VAR t: Tree) CountChildren (node: TreeNode): INTEGER, NEW; + VAR tot, nofc, i: INTEGER; + BEGIN + tot := 0; + IF node # NIL THEN + nofc := node.nofChildren; tot := nofc; + FOR i := 0 TO nofc -1 DO + tot := tot + t.CountChildren(t.Child(node, i)) + END + END; + RETURN tot + END CountChildren; + + PROCEDURE Exclude (IN t: Tree; node: TreeNode); + VAR c: TreeNode; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 100); + IF t.Selected() = node THEN t.Select(NIL) END; + node.tree := 0; + c := node.firstChild; + WHILE c # NIL DO Exclude(t, c); c := c.next END + END Exclude; + + PROCEDURE (VAR t: Tree) Delete* (node: TreeNode): INTEGER, NEW; + VAR + ndel: INTEGER; + BEGIN + ASSERT(node # NIL, 20); ASSERT(node.tree = SYSTEM.ADR(t), 21); + ndel := t.CountChildren(node); + IF node.parent = NIL THEN (* root node *) + IF node.prev = NIL THEN + IF node.next # NIL THEN + t.firstRoot := node.next; + node.next.prev := NIL + ELSE + t.firstRoot := NIL + END + ELSE + node.prev.next := node.next; + IF node.next # NIL THEN node.next.prev := node.prev END + END; + DEC(t.nofRoots) + ELSE + IF node.prev = NIL THEN + IF node.next # NIL THEN + node.parent.firstChild := node.next; + node.next.prev := NIL + ELSE + node.parent.firstChild := NIL + END + ELSE + node.prev.next := node.next; + IF node.next # NIL THEN node.next.prev := node.prev END + END; + DEC(node.parent.nofChildren) + END; + node.parent := NIL; node.next := NIL; node.prev := NIL; + Exclude(t, node); + ndel := ndel + 1; + t.nofNodes := t.nofNodes - ndel; + RETURN ndel + END Delete; + + PROCEDURE (VAR t: Tree) Move* (node, parent: TreeNode; pos: INTEGER), NEW; + VAR ndel, nofn: INTEGER; s: TreeNode; + BEGIN + ASSERT(node # NIL, 20); ASSERT(pos >= lastPos, 21); + ASSERT(node.tree = SYSTEM.ADR(t), 22); + nofn := t.NofNodes(); + s := t.Selected(); + ndel := t.Delete(node); t.InsertAt(parent, pos, node); + t.nofNodes := t.nofNodes + ndel - 1; + IF (s # NIL) & (t.Selected() # s) THEN t.Select(s) END; + ASSERT(nofn = t.NofNodes(), 60) + END Move; + + PROCEDURE (VAR t: Tree) DeleteAll*, NEW; + BEGIN + t.nofRoots := 0; t.nofNodes := 0; t.firstRoot := NIL; t.selected := NIL + END DeleteAll; + + + PROCEDURE Notify* (id0, id1: INTEGER; opts: SET); + BEGIN + ASSERT(notifyHook # NIL, 100); + notifyHook.Notify(id0, id1, opts) + END Notify; + + PROCEDURE Update* (IN x: ANYREC); + VAR type: Kernel.Type; adr, size: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + type := Kernel.TypeOf(x); + size := type.size; + IF size = 0 THEN size := 1 END; + Notify(adr, adr + size, {update, guardCheck}) + END Update; + + PROCEDURE UpdateBool* (VAR x: BOOLEAN); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(BOOLEAN), {update, guardCheck}) + END UpdateBool; + + PROCEDURE UpdateSChar* (VAR x: SHORTCHAR); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(SHORTCHAR), {update, guardCheck}) + END UpdateSChar; + + PROCEDURE UpdateChar* (VAR x: CHAR); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(CHAR), {update, guardCheck}) + END UpdateChar; + + PROCEDURE UpdateByte* (VAR x: BYTE); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(BYTE), {update, guardCheck}) + END UpdateByte; + + PROCEDURE UpdateSInt* (VAR x: SHORTINT); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(SHORTINT), {update, guardCheck}) + END UpdateSInt; + + PROCEDURE UpdateInt* (VAR x: INTEGER); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(INTEGER), {update, guardCheck}) + END UpdateInt; + + PROCEDURE UpdateLInt* (VAR x: LONGINT); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(LONGINT), {update, guardCheck}) + END UpdateLInt; + + PROCEDURE UpdateSReal* (VAR x: SHORTREAL); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(SHORTREAL), {update, guardCheck}) + END UpdateSReal; + + PROCEDURE UpdateReal* (VAR x: REAL); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(REAL), {update, guardCheck}) + END UpdateReal; + + PROCEDURE UpdateSet* (VAR x: SET); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + SIZE(SET), {update, guardCheck}) + END UpdateSet; + + PROCEDURE UpdateSString* (IN x: ARRAY OF SHORTCHAR); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + LEN(x) * SIZE(SHORTCHAR), {update, guardCheck}) + END UpdateSString; + + PROCEDURE UpdateString* (IN x: ARRAY OF CHAR); + VAR adr: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + Notify(adr, adr + LEN(x) * SIZE(CHAR), {update, guardCheck}) + END UpdateString; + + PROCEDURE UpdateList* (IN x: ANYREC); + VAR type: Kernel.Type; adr, size: INTEGER; + BEGIN + adr := SYSTEM.ADR(x); + type := Kernel.TypeOf(x); + size := type.size; + IF size = 0 THEN size := 1 END; + Notify(adr, adr + size, {listUpdate, guardCheck}) + END UpdateList; + + + PROCEDURE GetOK* (IN str, p0, p1, p2: ARRAY OF CHAR; form: SET; OUT res: INTEGER); + BEGIN + ASSERT(((yes IN form) = (no IN form)) & ((yes IN form) # (ok IN form)), 20); + ASSERT(gethook # NIL, 100); + gethook.GetOK(str, p0, p1, p2, form, res) + END GetOK; + + PROCEDURE GetIntSpec* (defType: Files.Type; VAR loc: Files.Locator; OUT name: Files.Name); + BEGIN + ASSERT(gethook # NIL, 100); + gethook.GetIntSpec(defType, loc, name) + END GetIntSpec; + + PROCEDURE GetExtSpec* (defName: Files.Name; defType: Files.Type; VAR loc: Files.Locator; + OUT name: Files.Name); + BEGIN + ASSERT(gethook # NIL, 100); + gethook.GetExtSpec(defName, defType, loc, name) + END GetExtSpec; + + PROCEDURE GetColor* (in: INTEGER; OUT out: INTEGER; OUT set: BOOLEAN); + BEGIN + ASSERT(gethook # NIL, 100); + gethook.GetColor(in, out, set) + END GetColor; + + + PROCEDURE Subst (in: ARRAY OF CHAR; IN p0, p1, p2: ARRAY OF CHAR; VAR out: ARRAY OF CHAR); + VAR len, i, j, k: INTEGER; ch, c: CHAR; + BEGIN + i := 0; ch := in[i]; j := 0; len := LEN(out) - 1; + WHILE (ch # 0X) & (j < len) DO + IF ch = "^" THEN + INC(i); ch := in[i]; + IF ch = "0" THEN + k := 0; c := p0[0]; + WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p0[k] END; + INC(i); ch := in[i] + ELSIF ch = "1" THEN + k := 0; c := p1[0]; + WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p1[k] END; + INC(i); ch := in[i] + ELSIF ch = "2" THEN + k := 0; c := p2[0]; + WHILE (c # 0X) & (j < len) DO out[j] := c; INC(j); INC(k); c := p2[k] END; + INC(i); ch := in[i] + ELSE out[j] := "^"; INC(j) + END + ELSE out[j] := ch; INC(j); INC(i); ch := in[i] + END + END; + out[j] := 0X + END Subst; + + PROCEDURE FlushMappings*; + BEGIN + tabList := NIL + END FlushMappings; + + PROCEDURE MapParamString* (in, p0, p1, p2: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + (* use in as key in string table file, and return corresponding string in out. + If the resource lookup fails, return in in out *) + BEGIN + SearchString(in, out); + IF out # "" THEN Subst(out, p0, p1, p2, out) + ELSE Subst(in, p0, p1, p2, out) + END + END MapParamString; + + PROCEDURE MapString* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + VAR len, k: INTEGER; + BEGIN + SearchString(in, out); + IF out = "" THEN + k := 0; len := LEN(out)-1; + WHILE (k < len) & (in[k] # 0X) DO out[k] := in[k]; INC(k) END; + out[k] := 0X + END + END MapString; + + PROCEDURE ShowMsg* (IN str: ARRAY OF CHAR); + BEGIN + ASSERT(str # "", 20); + ASSERT(showHook # NIL, 100); + showHook.ShowParamMsg(str, "", "", "") + END ShowMsg; + + PROCEDURE ShowParamMsg* (IN str, p0, p1, p2: ARRAY OF CHAR); + BEGIN + ASSERT(str # "", 20); + ASSERT(showHook # NIL, 100); + showHook.ShowParamMsg(str,p0, p1, p2) + END ShowParamMsg; + + PROCEDURE ShowStatus* (IN str: ARRAY OF CHAR); + BEGIN + ASSERT(showHook # NIL, 100); + showHook.ShowParamStatus(str, "", "", "") + END ShowStatus; + + PROCEDURE ShowParamStatus* (IN str, p0, p1, p2: ARRAY OF CHAR); + BEGIN + ASSERT(showHook # NIL, 100); + showHook.ShowParamStatus(str, p0, p1, p2) + END ShowParamStatus; + + + PROCEDURE Call* (IN proc, errorMsg: ARRAY OF CHAR; OUT res: INTEGER); + BEGIN + ASSERT(callHook # NIL, 100); + callHook.Call(proc, errorMsg, res) + END Call; + + PROCEDURE Beep*; + BEGIN + Kernel.Beep + END Beep; + + PROCEDURE (n: LangNotifier) Notify-(), NEW, ABSTRACT; + + PROCEDURE RegisterLangNotifier* (notifier: LangNotifier); + VAR nl: LangNotifier; + BEGIN + ASSERT(notifier # NIL, 20); + nl := langNotifiers; + WHILE (nl # NIL) & (nl # notifier) DO nl := nl.next END; + IF nl = NIL THEN + notifier.next := langNotifiers; langNotifiers := notifier + END + END RegisterLangNotifier; + + PROCEDURE RemoveLangNotifier* (notifier: LangNotifier); + VAR nl, prev: LangNotifier; + BEGIN + ASSERT(notifier # NIL, 20); + nl := langNotifiers; prev := NIL; + WHILE (nl # NIL) & (nl # notifier) DO prev := nl; nl := nl.next END; + IF nl # NIL THEN + IF prev = NIL THEN langNotifiers := langNotifiers.next ELSE prev.next := nl.next END; + nl.next := NIL + END + END RemoveLangNotifier; + + PROCEDURE Exec (a, b, c: INTEGER); + VAR nl: LangNotifier; + BEGIN + nl := currentNotifier; currentNotifier := NIL; + nl.Notify; + currentNotifier := nl + END Exec; + + PROCEDURE SetLanguage* (lang: Language; persistent: BOOLEAN); + VAR nl, t: LangNotifier; ok: BOOLEAN; + BEGIN + ASSERT((lang = "") OR (LEN(lang$) = 2), 20); + ASSERT(languageHook # NIL, 100); + IF lang # language THEN + languageHook.SetLanguage(lang, persistent, ok); + IF ok THEN + language := lang; FlushMappings; + nl := langNotifiers; + WHILE nl # NIL DO + currentNotifier := nl; + Kernel.Try(Exec, 0, 0, 0); + IF currentNotifier = NIL THEN + t := nl; nl := nl.next; RemoveLangNotifier(t) (* Notifier trapped, remove it *) + ELSE + nl := nl.next + END + END + END; + currentNotifier := NIL + END + END SetLanguage; + + PROCEDURE ResetLanguage*; + VAR lang: Language; + BEGIN + ASSERT(languageHook # NIL, 100); + languageHook.GetPersistentLanguage(lang); + SetLanguage(lang, nonPersistent) + END ResetLanguage; + +BEGIN + appName := "BlackBox"; showsStatus := FALSE; caretPeriod := 500; thickCaret := FALSE; user := "" +END Dialog. diff --git a/Trurl-based/System/Mod/Documents.txt b/Trurl-based/System/Mod/Documents.txt new file mode 100644 index 0000000..2450a66 --- /dev/null +++ b/Trurl-based/System/Mod/Documents.txt @@ -0,0 +1,1286 @@ +MODULE Documents; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Documents.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Files, Ports, Dates, Printers, + Stores, Sequencers, Models, Views, Controllers, Properties, + Dialog, Printing, Containers; + + CONST + (** Document.SetPage/PollPage decorate **) + plain* = FALSE; decorate* = TRUE; + + (** Controller.opts **) + pageWidth* = 16; pageHeight* = 17; winWidth* = 18; winHeight* = 19; + + point = Ports.point; + mm = Ports.mm; + + defB = 8 * point; (* defB also used by HostWindows in DefBorders *) + + scrollUnit = 16 * point; + abort = 1; + + resizingKey = "#System:Resizing"; + pageSetupKey = "#System:PageSetup"; + + docTag = 6F4F4443H; docVersion = 0; + + minVersion = 0; maxModelVersion = 0; maxCtrlVersion = 0; + maxDocVersion = 0; maxStdDocVersion = 0; + + + TYPE + Document* = POINTER TO ABSTRACT RECORD (Containers.View) END; + + Context* = POINTER TO ABSTRACT RECORD (Models.Context) END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + + Model = POINTER TO RECORD (Containers.Model) + doc: StdDocument; + view: Views.View; + l, t, r, b: INTEGER (* possibly r, b >= Views.infinite *) + (* l, t: constant (= defB) *) + (* r-l, b-t: invalid in some cases, use PollRect *) + END; + + Controller = POINTER TO RECORD (Containers.Controller) + doc: StdDocument + END; + + StdDocument = POINTER TO RECORD (Document) + model: Model; + original: StdDocument; (* original # NIL => d IS copy of original *) + pw, ph, pl, pt, pr, pb: INTEGER; (* invalid if original # NIL, use PollPage *) + decorate: BOOLEAN; + x, y: INTEGER (* scroll state *) + END; + + StdContext = POINTER TO RECORD (Context) + model: Model + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + SetRectOp = POINTER TO RECORD (Stores.Operation) + model: Model; + w, h: INTEGER + END; + SetPageOp = POINTER TO RECORD (Stores.Operation) + d: StdDocument; + pw, ph, pl, pt, pr, pb: INTEGER; + decorate: BOOLEAN + END; + ReplaceViewOp = POINTER TO RECORD (Stores.Operation) + model: Model; + new: Views.View + END; + + PrinterContext = POINTER TO RECORD (Models.Context) + param: Printing.Par; + date: Dates.Date; + time: Dates.Time; + pr: Printers.Printer; + l, t, r, b: INTEGER; (* frame *) + pw, ph: INTEGER (* paper *) + END; + + UpdateMsg = RECORD (Views.Message) + doc: StdDocument + END; + + + PContext = POINTER TO RECORD (Models.Context) + view: Views.View; + w, h: INTEGER (* content size *) + END; + Pager = POINTER TO RECORD (Views.View) + con: PContext; + w, h: INTEGER; (* page size *) + x, y: INTEGER (* origin *) + END; + + PrintingHook = POINTER TO RECORD (Printing.Hook) END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + + VAR + dir-, stdDir-: Directory; + cleaner: TrapCleaner; + current: INTEGER; + + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + Printing.par := NIL; current := -1 + END Cleanup; + + + (** Document **) + + PROCEDURE (d: Document) Internalize2- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxDocVersion, thisVersion) + END Internalize2; + + PROCEDURE (d: Document) Externalize2- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + wr.WriteVersion(maxDocVersion) + END Externalize2; + + PROCEDURE (d: Document) GetNewFrame* (VAR frame: Views.Frame); + VAR f: Views.RootFrame; + BEGIN + NEW(f); frame := f + END GetNewFrame; + + PROCEDURE (d: Document) GetBackground* (VAR color: Ports.Color); + BEGIN + color := Ports.background + END GetBackground; + + PROCEDURE (d: Document) DocCopyOf* (v: Views.View): Document, NEW, ABSTRACT; + PROCEDURE (d: Document) SetView* (view: Views.View; w, h: INTEGER), NEW, ABSTRACT; + PROCEDURE (d: Document) ThisView* (): Views.View, NEW, ABSTRACT; + PROCEDURE (d: Document) OriginalView* (): Views.View, NEW, ABSTRACT; + + PROCEDURE (d: Document) SetRect* (l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (d: Document) PollRect* (VAR l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (d: Document) SetPage* (w, h, l, t, r, b: INTEGER; decorate: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (d: Document) PollPage* (VAR w, h, l, t, r, b: INTEGER; + VAR decorate: BOOLEAN), NEW, ABSTRACT; + + + (** Context **) + + PROCEDURE (c: Context) ThisDoc* (): Document, NEW, ABSTRACT; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (view: Views.View; w, h: INTEGER): Document, NEW, ABSTRACT; + + + (* operations *) + + PROCEDURE (op: SetRectOp) Do; + VAR m: Model; w, h: INTEGER; upd: UpdateMsg; + BEGIN + m := op.model; + w := m.r - m.l; h := m.b - m.t; + m.r := m.l + op.w; m.b := m.t + op.h; + op.w := w; op.h := h; + IF m.doc.context # NIL THEN + upd.doc := m.doc; + Views.Domaincast(m.doc.Domain(), upd) + END + END Do; + + PROCEDURE (op: SetPageOp) Do; + VAR d: StdDocument; pw, ph, pl, pt, pr, pb: INTEGER; decorate: BOOLEAN; upd: UpdateMsg; + BEGIN + d := op.d; + pw := d.pw; ph := d.ph; pl := d.pl; pt := d.pt; pr := d.pr; pb := d.pb; + decorate := d.decorate; + d.pw := op.pw; d.ph := op.ph; d.pl := op.pl; d.pt := op.pt; d.pr := op.pr; d.pb := op.pb; + d.decorate := op.decorate; + op.pw := pw; op.ph := d.ph; op.pl := pl; op.pt := pt; op.pr := pr; op.pb := pb; + op.decorate := decorate; + IF d.context # NIL THEN + upd.doc := d; + Views.Domaincast(d.Domain(), upd) + END + END Do; + + PROCEDURE (op: ReplaceViewOp) Do; + VAR new: Views.View; upd: UpdateMsg; + BEGIN + new := op.new; op.new := op.model.view; op.model.view := new; + upd.doc := op.model.doc; + IF upd.doc.context # NIL THEN + Views.Domaincast(upd.doc.Domain(), upd) + END + END Do; + + + (* printing support for StdDocument *) + + PROCEDURE CheckOrientation (d: Document; prt: Printers.Printer); + VAR w, h, l, t, r, b: INTEGER; decorate: BOOLEAN; + BEGIN + d.PollPage(w, h, l, t, r, b, decorate); + prt.SetOrientation(w > h) + END CheckOrientation; + + PROCEDURE NewPrinterContext (d: Document; prt: Printers.Printer; p: Printing.Par): PrinterContext; + VAR c: PrinterContext; + pw, ph, x0, y0, x1, y1, l, t, r, b: INTEGER; decorate: BOOLEAN; + BEGIN + prt.GetRect(x0, y0, x1, y1); + d.PollPage(pw, ph, l, t, r, b, decorate); + INC(l, x0); INC(t, y0); INC(r, x0); INC(b, y0); + NEW(c); (* c.Domain() := d.Domain(); (* dom *)*) c.param := p; Dates.GetDate(c.date); Dates.GetTime(c.time); + c.pr := prt; + c.l := l; c.t := t; c.r := r; c.b := b; + c.pw := pw + 2 * x0; c.ph := ph + 2 * y0; (* paper reduced to printer range *) + RETURN c + END NewPrinterContext; + + PROCEDURE Decorate (c: PrinterContext; f: Views.Frame); + VAR p: Printing.Par; x0, x1, y, asc, dsc, w: INTEGER; alt: BOOLEAN; + BEGIN + p := c.param; + alt := p.page.alternate & ~ODD(p.page.first + Printing.Current() (* p.page.current *)); + IF alt THEN x0 := c.pw - c.r; x1 := c.pw - c.l + ELSE x0 := c.l; x1 := c.r + END; + IF (alt & (p.header.left # "")) OR (~alt & (p.header.right # "")) THEN + p.header.font.GetBounds(asc, dsc, w); + y := c.t - p.header.gap - dsc; + Printing.PrintBanner(f, p.page, p.header, c.date, c.time, x0, x1, y) + END; + IF (alt & (p.footer.left # "")) OR (~alt & (p.footer.right # "")) THEN + p.footer.font.GetBounds(asc, dsc, w); + y := c.b + p.footer.gap + asc; + Printing.PrintBanner(f, p.page, p.footer, c.date, c.time, x0, x1, y) + END + END Decorate; + + + (* support for StdDocument paging *) + + PROCEDURE HasFocus (v: Views.View; f: Views.Frame): BOOLEAN; + VAR focus: Views.View; dummy: Controllers.PollFocusMsg; + BEGIN + focus := NIL; dummy.focus := NIL; + v.HandleCtrlMsg(f, dummy, focus); + RETURN focus # NIL + END HasFocus; + + PROCEDURE ScrollDoc(v: StdDocument; x, y: INTEGER); + BEGIN + IF (x # v.x) OR (y # v.y) THEN + Views.Scroll(v, x - v.x, y - v.y); + v.x := x; v.y := y + END + END ScrollDoc; + + PROCEDURE PollSection (v: StdDocument; f: Views.Frame; VAR msg: Controllers.PollSectionMsg); + VAR mv: Views.View; g: Views.Frame; vs, ps, ws, p, l, t, r, b: INTEGER; c: Containers.Controller; + BEGIN + mv := v.model.view; + g := Views.ThisFrame(f, mv); + c := v.ThisController(); + IF c.Singleton() # NIL THEN g := NIL END; + IF g # NIL THEN Views.ForwardCtrlMsg(g, msg) END; + IF (g = NIL) OR ~msg.done & (~msg.focus OR ~HasFocus(mv, g)) THEN + v.PollRect(l, t, r, b); + IF msg.vertical THEN + ps := f.b - f.t; vs := b + t; p := -v.y + ELSE + ps := f.r - f.l; vs := r + l; p := -v.x + END; + IF ps > vs THEN ps := vs END; + ws := vs - ps; + IF p > ws THEN + p := ws; + IF msg.vertical THEN ScrollDoc(v, v.x, -p) + ELSE ScrollDoc(v, -p, v.y) + END + END; + msg.wholeSize := vs; + msg.partSize := ps; + msg.partPos := p; + msg.valid := ws > Ports.point + END; + msg.done := TRUE + END PollSection; + + PROCEDURE Scroll (v: StdDocument; f: Views.Frame; VAR msg: Controllers.ScrollMsg); + VAR mv: Views.View; g: Views.Frame; vs, ps, ws, p, l, t, r, b: INTEGER; c: Containers.Controller; + BEGIN + mv := v.model.view; + g := Views.ThisFrame(f, mv); + c := v.ThisController(); + IF c.Singleton() # NIL THEN g := NIL END; + IF g # NIL THEN Views.ForwardCtrlMsg(g, msg) END; + IF (g = NIL) OR ~msg.done & (~msg.focus OR ~HasFocus(mv, g)) THEN + v.PollRect(l, t, r, b); + IF msg.vertical THEN + ps := f.b - f.t; vs := b + t; p := -v.y + ELSE + ps := f.r - f.l; vs := r + l; p := -v.x + END; + ws := vs - ps; + CASE msg.op OF + Controllers.decLine: p := MAX(0, p - scrollUnit) + | Controllers.incLine: p := MIN(ws, p + scrollUnit) + | Controllers.decPage: p := MAX(0, p - ps + scrollUnit) + | Controllers.incPage: p := MIN(ws, p + ps - scrollUnit) + | Controllers.gotoPos: p := MAX(0, MIN(ws, msg.pos)) + ELSE + END; + IF msg.vertical THEN ScrollDoc(v, v.x, -p) + ELSE ScrollDoc(v, -p, v.y) + END + END; + msg.done := TRUE + END Scroll; + + PROCEDURE MakeVisible* (d: Document; f: Views.Frame; l, t, r, b: INTEGER); + VAR x, y, w, h, dw, dh, ml, mt, mr, mb: INTEGER; + BEGIN + WITH d: StdDocument DO + d.context.GetSize(w, h); + x := -d.x; y := -d.y; + d.PollRect(ml, mt, mr, mb); + dw := mr + ml - w; dh := mb + mt - h; + IF dw > 0 THEN + IF r > x + w - 2 * ml THEN x := r - w + 2 * ml END; + IF l < x THEN x := l END; + IF x < 0 THEN x := 0 ELSIF x > dw THEN x := dw END + END; + IF dh > 0 THEN + IF b > y + h - 2 * mt THEN y := b - h + 2 * mt END; + IF t < y THEN y := t END; + IF y < 0 THEN y := 0 ELSIF y > dh THEN y := dh END + END; + ScrollDoc(d, -x, -y) + END + END MakeVisible; + + PROCEDURE Page (d: StdDocument; f: Views.Frame; + VAR msg: Controllers.PageMsg); + VAR g: Views.Frame; + BEGIN + g := Views.ThisFrame(f, d.model.view); + IF g # NIL THEN Views.ForwardCtrlMsg(g, msg) END + END Page; + + + (* Model *) + + PROCEDURE (m: Model) Internalize (VAR rd: Stores.Reader); + VAR c: StdContext; thisVersion: INTEGER; l, t, r, b: INTEGER; + BEGIN + m.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxModelVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + Views.ReadView(rd, m.view); + rd.ReadInt(l); rd.ReadInt(t); rd.ReadInt(r); rd.ReadInt(b); + m.l := defB; m.t := defB; m.r := defB + r - l; m.b := defB + b - t; + NEW(c); c.model := m; m.view.InitContext(c) + END Internalize; + + PROCEDURE (m: Model) Externalize (VAR wr: Stores.Writer); + BEGIN + ASSERT(m.doc.original = NIL, 100); + m.Externalize^(wr); + wr.WriteVersion(maxModelVersion); + Views.WriteView(wr, m.view); + wr.WriteInt(m.l); wr.WriteInt(m.t); wr.WriteInt(m.r); wr.WriteInt(m.b) + END Externalize; + + PROCEDURE (m: Model) CopyFrom (source: Stores.Store); + VAR c: StdContext; + BEGIN + WITH source: Model DO + m.view := Stores.CopyOf(source.view)(Views.View); + m.l := source.l; m.t := source.t; m.r := source.r; m.b := source.b; + NEW(c); c.model := m; m.view.InitContext(c) + END + END CopyFrom; + + PROCEDURE (m: Model) InitFrom (source: Containers.Model); + VAR c: StdContext; + BEGIN + WITH source: Model DO + m.view := Stores.CopyOf(source.view)(Views.View); + m.l := source.l; m.t := source.t; m.r := source.r; m.b := source.b; + NEW(c); c.model := m; m.view.InitContext(c) + END + END InitFrom; + + PROCEDURE (m: Model) GetEmbeddingLimits (OUT minW, maxW, minH, maxH: INTEGER); + BEGIN + minW := 5 * mm; minH := 5 * mm; + maxW := MAX(INTEGER) DIV 2; maxH := MAX(INTEGER) DIV 2 + END GetEmbeddingLimits; + + PROCEDURE (m: Model) ReplaceView (old, new: Views.View); + VAR con: Models.Context; op: ReplaceViewOp; + BEGIN + ASSERT(old # NIL, 20); con := old.context; + ASSERT(con # NIL, 21); ASSERT(con.ThisModel() = m, 22); + ASSERT(new # NIL, 23); + ASSERT((new.context = NIL) OR (new.context = con), 24); + IF new # old THEN + IF new.context = NIL THEN new.InitContext(con) END; + Stores.Join(m, new); + NEW(op); op.model := m; op.new := new; + Models.Do(m, "#System:ReplaceView", op) + END + END ReplaceView; + + + (* StdDocument *) + + PROCEDURE (d: StdDocument) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; c: Containers.Controller; + BEGIN + d.Internalize2^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdDocVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadInt(d.pw); rd.ReadInt(d.ph); + rd.ReadInt(d.pl); rd.ReadInt(d.pt); rd.ReadInt(d.pr); rd.ReadInt(d.pb); + rd.ReadBool(d.decorate); + (* change infinite height to "fit to window" *) + c := d.ThisController(); + IF (c # NIL) & (d.model.b >= 29000 * Ports.mm) & (c.opts * {winHeight, pageHeight} = {}) THEN + c.SetOpts(c.opts + {winHeight}) + END; + c.SetOpts(c.opts - {Containers.noSelection}); + d.x := 0; d.y := 0; + Stores.InitDomain(d) + END Internalize2; + + PROCEDURE (d: StdDocument) Externalize2 (VAR wr: Stores.Writer); + BEGIN + ASSERT(d.original = NIL, 100); + d.Externalize2^(wr); + wr.WriteVersion(maxStdDocVersion); + wr.WriteInt(d.pw); wr.WriteInt(d.ph); + wr.WriteInt(d.pl); wr.WriteInt(d.pt); wr.WriteInt(d.pr); wr.WriteInt(d.pb); + wr.WriteBool(d.decorate) + END Externalize2; + + PROCEDURE (d: StdDocument) CopyFromModelView2 (source: Views.View; model: Models.Model); + BEGIN + WITH source: StdDocument DO + d.pw := source.pw; d.ph := source.ph; + d.pl := source.pl; d.pt := source.pt; d.pr := source.pr; d.pb := source.pb; + d.decorate := source.decorate + END + END CopyFromModelView2; + + PROCEDURE (d: StdDocument) AcceptableModel (m: Containers.Model): BOOLEAN; + BEGIN + RETURN m IS Model + END AcceptableModel; + + PROCEDURE (d: StdDocument) InitModel2 (m: Containers.Model); + BEGIN + ASSERT((d.model = NIL) OR (d.model = m), 20); + ASSERT(m IS Model, 23); + WITH m: Model DO d.model := m; m.doc := d END + END InitModel2; + + PROCEDURE (d: StdDocument) PollRect (VAR l, t, r, b: INTEGER); + VAR c: Containers.Controller; doc: StdDocument; ww, wh, pw, ph: INTEGER; + BEGIN + IF d.original = NIL THEN doc := d ELSE doc := d.original END; + l := d.model.l; t := d.model.t; + pw := doc.pr - doc.pl; ph := doc.pb - doc.pt; + IF d.context = NIL THEN ww := 0; wh := 0 + ELSIF d.context IS PrinterContext THEN ww := pw; wh := ph + ELSE d.context.GetSize(ww, wh); DEC(ww, 2 * l); DEC(wh, 2 * t) + END; + c := d.ThisController(); + IF pageWidth IN c.opts THEN r := l + pw + ELSIF winWidth IN c.opts THEN + IF ww > 0 THEN r := l + ww ELSE r := d.model.r END + ELSE r := l + doc.model.r - doc.model.l + END; + IF pageHeight IN c.opts THEN b := t + ph + ELSIF winHeight IN c.opts THEN + IF wh > 0 THEN b := t + wh ELSE b := d.model.b END + ELSE b := t + doc.model.b - doc.model.t + END; + ASSERT(r > l, 60); ASSERT(b > t, 61) + END PollRect; + + PROCEDURE (d: StdDocument) PollPage (VAR w, h, l, t, r, b: INTEGER; VAR decorate: BOOLEAN); + VAR doc: StdDocument; + BEGIN + IF d.original = NIL THEN doc := d ELSE doc := d.original END; + w := doc.pw; h := doc.ph; + l := doc.pl; t := doc.pt; r := doc.pr; b := doc.pb; + decorate := doc.decorate + END PollPage; + + PROCEDURE (d: StdDocument) DocCopyOf (v: Views.View): Document; + VAR c0, c1: Containers.Controller; u: Views.View; new: Document; w, h: INTEGER; + BEGIN + ASSERT(v # NIL, 20); + ASSERT(~(v IS Document), 21); + ASSERT(d.Domain() = v.Domain(), 22); + ASSERT(d.Domain() # NIL, 23); + Views.BeginModification(3, v); + u := Views.CopyOf(v, Views.shallow); + v.context.GetSize(w, h); + new := dir.New(u, w, h); + WITH new: StdDocument DO + IF d.original # NIL THEN new.original := d.original ELSE new.original := d END + END; + c0 := d.ThisController(); + c1 := new.ThisController(); + c1.SetOpts(c0.opts); + Views.EndModification(3, v); + RETURN new + END DocCopyOf; + + PROCEDURE (d: StdDocument) Restore (f: Views.Frame; l, t, r, b: INTEGER); + VAR c: Containers.Controller; m: Model; con: Models.Context; s: Views.View; + BEGIN + m := d.model; con := d.context; + WITH con: PrinterContext DO + IF con.param.page.alternate & ~ODD(con.param.page.first + Printing.Current()) THEN + Views.InstallFrame(f, m.view, con.pw - con.r, con.t, 0, FALSE) + ELSE + Views.InstallFrame(f, m.view, con.l, con.t, 0, FALSE) + END + ELSE + c := d.ThisController(); s := c.Singleton(); + Views.InstallFrame(f, m.view, m.l + d.x, m.t + d.y, 0, s = NIL) + END + END Restore; + + PROCEDURE (d: StdDocument) GetRect (f: Views.Frame; view: Views.View; OUT l, t, r, b: INTEGER); + VAR l0, t0, r0, b0: INTEGER; + BEGIN + d.PollRect(l0, t0, r0, b0); + l := l0 + d.x; t := t0 + d.y; r := r0 + d.x; b := b0 + d.y + END GetRect; + + PROCEDURE (d: StdDocument) SetView (view: Views.View; w, h: INTEGER); + CONST + wA4 = 210 * mm; hA4 = 296 * mm; (* A4 default paper size *) + lm = 20 * mm; tm = 20 * mm; rm = 20 * mm; bm = 20 * mm; + VAR m: Model; c: StdContext; prt: Printers.Printer; + ctrl: Containers.Controller; opts: SET; rp: Properties.ResizePref; + u, minW, maxW, minH, maxH, defW, defH, dw, dh, pw, ph, + pageW, pageH, paperW, paperH, leftM, topM, rightM, botM: INTEGER; + l, t, r, b: INTEGER; port: Ports.Port; + BEGIN + ASSERT(view # NIL, 20); ASSERT(~(view IS Document), 21); + ASSERT(d.original = NIL, 100); + m := d.model; + NEW(c); c.model := m; view.InitContext(c); + IF d.context # NIL THEN Stores.Join(d, view) END; + IF Printers.dir # NIL THEN prt := Printers.dir.Current() ELSE prt := NIL END; + IF prt # NIL THEN + prt.SetOrientation(FALSE); + port := prt.ThisPort(); prt.GetRect(l, t, r, b); + port.GetSize(pw, ph); u := port.unit; + paperW := r - l; paperH := b - t; + pageW := paperW - lm - rm; pageH := paperH - tm - bm; + leftM := lm; topM := tm; rightM := rm; botM := bm; + IF pageW > pw * u THEN pageW := pw * u END; + IF pageH > ph * u THEN pageH := ph * u END; + IF leftM + l < 0 THEN dw := -(leftM + l) + ELSIF paperW - rightM + l > pw * u THEN dw := pw * u - (paperW - rightM + l) + ELSE dw := 0 + END; + IF topM + t < 0 THEN dh := -(topM + t) + ELSIF paperH - botM + t > ph * u THEN dh := ph * u - (paperH - botM + t) + ELSE dh := 0 + END; + INC(leftM, dw); INC(topM, dh); INC(rightM, dw); INC(botM, dh) + ELSE + paperW := wA4; paperH := hA4; + pageW := paperW - lm - rm; pageH := paperH - tm - bm; + leftM := lm; topM := tm; rightM := rm; botM := bm + END; + m.GetEmbeddingLimits(minW, maxW, minH, maxH); + defW := MAX(minW, pageW - m.l - defB); + defH := MAX(minH, pageH - m.t - defB); + Properties.PreferredSize(view, minW, maxW, minH, maxH, defW, defH, w, h); + opts := {}; rp.fixed := FALSE; + rp.horFitToPage := FALSE; + rp.verFitToPage := FALSE; + rp.horFitToWin := FALSE; + rp.verFitToWin := FALSE; + Views.HandlePropMsg(view, rp); + IF rp.horFitToPage THEN INCL(opts, pageWidth) + ELSIF rp.horFitToWin THEN INCL(opts, winWidth) + END; + IF rp.verFitToPage THEN INCL(opts, pageHeight) + ELSIF rp.verFitToWin THEN INCL(opts, winHeight) + END; + Views.BeginModification(Views.notUndoable, d); + m.view := view; d.x := 0; d.y := 0; + ctrl := d.ThisController(); + ctrl.SetOpts(ctrl.opts - {pageWidth..winHeight}); + d.SetPage(paperW, paperH, leftM, topM, paperW - rightM, paperH - botM, plain); + ASSERT(w > 0, 100); ASSERT(h > 0, 101); + d.SetRect(m.l, m.t, m.l + w, m.t + h); + ctrl.SetOpts(ctrl.opts + opts); + Views.EndModification(Views.notUndoable, d); + Stores.Join(d, view); + Views.Update(d, Views.rebuildFrames) + END SetView; + + PROCEDURE (d: StdDocument) ThisView (): Views.View; + BEGIN + RETURN d.model.view + END ThisView; + + PROCEDURE (d: StdDocument) OriginalView (): Views.View; + BEGIN + IF d.original = NIL THEN RETURN d.model.view + ELSE RETURN d.original.model.view + END + END OriginalView; + + PROCEDURE (d: StdDocument) SetRect (l, t, r, b: INTEGER); + VAR m: Model; op: SetRectOp; c: Containers.Controller; w, h: INTEGER; + BEGIN + ASSERT(l < r, 22); ASSERT(t < b, 25); + m := d.model; + IF (m.l # l) OR (m.t # t) THEN + m.r := l + m.r - m.l; m.l := l; + m.b := t + m.b - m.t; m.t := t; + Views.Update(d, Views.rebuildFrames) + END; + IF d.original # NIL THEN m := d.original.model END; + c := d.ThisController(); w := r - l; h := b - t; + IF (pageWidth IN c.opts) OR (winWidth IN c.opts) THEN w := m.r - m.l END; + IF (pageHeight IN c.opts) OR (winHeight IN c.opts) THEN h := m.b - m.t END; + IF (w # m.r - m.l) OR (h # m.b - m.t) THEN + NEW(op); op.model := m; op.w:= w; op.h := h; + Views.Do(d, resizingKey, op) + END + END SetRect; + + PROCEDURE (d: StdDocument) SetPage (pw, ph, pl, pt, pr, pb: INTEGER; decorate: BOOLEAN); + VAR op: SetPageOp; doc: StdDocument; + BEGIN + IF d.original = NIL THEN doc := d ELSE doc := d.original END; + IF (doc.pw # pw) OR (doc.ph # ph) OR (doc.decorate # decorate) + OR (doc.pl # pl) OR (doc.pt # pt) OR (doc.pr # pr) OR (doc.pb # pb) THEN + ASSERT(0 <= pw, 20); + ASSERT(0 <= ph, 22); + ASSERT(0 <= pl, 24); ASSERT(pl < pr, 25); ASSERT(pr <= pw, 26); + ASSERT(0 <= pt, 27); ASSERT(pt < pb, 28); ASSERT(pb <= ph, 29); + NEW(op); + op.d := doc; + op.pw := pw; op.ph := ph; op.pl := pl; op.pt := pt; op.pr := pr; op.pb := pb; + op.decorate := decorate; + Views.Do(doc, pageSetupKey, op) + END + END SetPage; + + PROCEDURE (v: StdDocument) HandleViewMsg2 (f: Views.Frame; VAR msg: Views.Message); + BEGIN + WITH msg: UpdateMsg DO + IF (msg.doc = v) OR (msg.doc = v.original) THEN + Views.Update(v, Views.rebuildFrames) + END + ELSE + END + END HandleViewMsg2; + + PROCEDURE (d: StdDocument) HandleCtrlMsg2 (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH f: Views.RootFrame DO + WITH msg: Controllers.PollSectionMsg DO + PollSection(d, f, msg); focus := NIL + | msg: Controllers.ScrollMsg DO + Scroll(d, f, msg); focus := NIL + | msg: Controllers.PageMsg DO + Page(d, f, msg); focus := NIL + ELSE + END + END + END HandleCtrlMsg2; + + + (* Controller *) + + PROCEDURE (c: Controller) Internalize2 (VAR rd: Stores.Reader); + VAR v: INTEGER; + BEGIN + rd.ReadVersion(minVersion, maxCtrlVersion, v) + END Internalize2; + + PROCEDURE (c: Controller) Externalize2 (VAR wr: Stores.Writer); + BEGIN + wr.WriteVersion(maxCtrlVersion) + END Externalize2; + + PROCEDURE (c: Controller) InitView2 (v: Views.View); + BEGIN + IF v # NIL THEN c.doc := v(StdDocument) ELSE c.doc := NIL END + END InitView2; + + PROCEDURE (c: Controller) GetContextType (OUT type: Stores.TypeName); + END GetContextType; + + PROCEDURE (c: Controller) GetValidOps (OUT valid: SET); + BEGIN + IF c.Singleton() # NIL THEN + valid := {Controllers.copy} + END + END GetValidOps; + + PROCEDURE (c: Controller) NativeModel (m: Models.Model): BOOLEAN; + BEGIN + RETURN m IS Model + END NativeModel; + + PROCEDURE (c: Controller) NativeView (v: Views.View): BOOLEAN; + BEGIN + RETURN v IS StdDocument + END NativeView; + + PROCEDURE (c: Controller) NativeCursorAt (f: Views.Frame; x, y: INTEGER): INTEGER; + BEGIN + RETURN Ports.arrowCursor + END NativeCursorAt; + + PROCEDURE (c: Controller) PollNativeProp (selection: BOOLEAN; VAR p: Properties.Property; + VAR truncated: BOOLEAN); + END PollNativeProp; + + PROCEDURE (c: Controller) SetNativeProp (selection: BOOLEAN; p, old: Properties.Property); + END SetNativeProp; + + PROCEDURE (c: Controller) GetFirstView (selection: BOOLEAN; OUT v: Views.View); + BEGIN + IF selection THEN v := c.Singleton() ELSE v := c.doc.model.view END + END GetFirstView; + + PROCEDURE (c: Controller) GetNextView (selection: BOOLEAN; VAR v: Views.View); + BEGIN + v := NIL + END GetNextView; + + PROCEDURE (c: Controller) GetPrevView (selection: BOOLEAN; VAR v: Views.View); + BEGIN + v := NIL + END GetPrevView; + + PROCEDURE (c: Controller) TrackMarks (f: Views.Frame; x, y: INTEGER; + units, extend, add: BOOLEAN); + BEGIN + c.Neutralize + END TrackMarks; + + PROCEDURE (c: Controller) RestoreMarks2 (f: Views.Frame; l, t, r, b: INTEGER); + BEGIN + IF c.doc.context IS PrinterContext THEN Decorate(c.doc.context(PrinterContext), f) END + END RestoreMarks2; + + PROCEDURE (c: Controller) Resize (view: Views.View; l, t, r, b: INTEGER); + VAR d: StdDocument; l0, t0: INTEGER; + BEGIN + d := c.doc; + ASSERT(view = d.model.view, 20); + l0 := d.model.l; t0 := d.model.t; + d.SetRect(l0, t0, l0 + r - l, t0 + b - t) + END Resize; + + PROCEDURE (c: Controller) DeleteSelection; + END DeleteSelection; + + PROCEDURE (c: Controller) MoveLocalSelection (f, dest: Views.Frame; x, y: INTEGER; + dx, dy: INTEGER); + VAR m: Model; l, t, r, b: INTEGER; + BEGIN + IF f = dest THEN + m := c.doc.model; DEC(dx, x); DEC(dy, y); + l := m.l + dx; t := m.t + dy; + r := m.r + dx; b := m.b + dy; + c.Resize(m.view, l, t, r, b); + IF c.Singleton() = NIL THEN c.SetSingleton(m.view) END + END + END MoveLocalSelection; + + PROCEDURE (c: Controller) SelectionCopy (): Model; + BEGIN + RETURN NIL + END SelectionCopy; + + PROCEDURE (c: Controller) NativePaste (m: Models.Model; f: Views.Frame); + VAR m0: Model; + BEGIN + WITH m: Model DO + m0 := c.doc.model; + m0.ReplaceView(m0.view, m.view); + c.doc.SetRect(m.l, m.t, m.r, m.b) + END + END NativePaste; + + PROCEDURE (c: Controller) PasteView (f: Views.Frame; v: Views.View; w, h: INTEGER); + VAR m: Model; minW, maxW, minH, maxH, defW, defH: INTEGER; + BEGIN + m := c.doc.model; + m.GetEmbeddingLimits(minW, maxW, minH, maxH); + defW := m.r - m.l; defH := m.b - m.t; + Properties.PreferredSize(v, minW, maxW, minH, maxH, defW, defH, w, h); + m.ReplaceView(m.view, v); + c.doc.SetRect(m.l, m.t, m.l + w, m.t + h) + END PasteView; + + PROCEDURE (c: Controller) Drop (src, dst: Views.Frame; sx, sy, x, y, w, h, rx, ry: INTEGER; + v: Views.View; isSingle: BOOLEAN); + VAR m: Model; minW, maxW, minH, maxH, defW, defH: INTEGER; + BEGIN + m := c.doc.model; + m.GetEmbeddingLimits(minW, maxW, minH, maxH); + defW := m.r - m.l; defH := m.b - m.t; + Properties.PreferredSize(v, minW, maxW, minH, maxH, defW, defH, w, h); + m.ReplaceView(m.view, v); + c.doc.SetRect(m.l, m.t, m.l + w, m.t + h) + END Drop; + + (* selection *) + + PROCEDURE (c: Controller) Selectable (): BOOLEAN; + BEGIN + RETURN TRUE + END Selectable; + + PROCEDURE (c: Controller) SelectAll (select: BOOLEAN); + BEGIN + IF ~select & (c.Singleton() # NIL) THEN + c.SetSingleton(NIL) + ELSIF select & (c.Singleton() = NIL) THEN + c.SetSingleton(c.doc.model.view) + END + END SelectAll; + + PROCEDURE (c: Controller) InSelection (f: Views.Frame; x, y: INTEGER): BOOLEAN; + BEGIN + RETURN c.Singleton() # NIL + END InSelection; + + (* caret *) + + PROCEDURE (c: Controller) HasCaret (): BOOLEAN; + BEGIN + RETURN FALSE + END HasCaret; + + PROCEDURE (c: Controller) MarkCaret (f: Views.Frame; show: BOOLEAN); + END MarkCaret; + + PROCEDURE (c: Controller) CanDrop (f: Views.Frame; x, y: INTEGER): BOOLEAN; + BEGIN + RETURN FALSE + END CanDrop; + + (* handlers *) + + PROCEDURE (c: Controller) HandleCtrlMsg (f: Views.Frame; + VAR msg: Controllers.Message; VAR focus: Views.View); + VAR l, t, r, b: INTEGER; + BEGIN + IF ~(Containers.noFocus IN c.opts) THEN + WITH msg: Controllers.TickMsg DO + IF c.Singleton() = NIL THEN c.SetFocus(c.doc.model.view) END + | msg: Controllers.CursorMessage DO + IF c.Singleton() = NIL THEN (* delegate to focus, even if not directly hit *) + focus := c.ThisFocus(); + c.doc.GetRect(f, focus, l, t, r, b); (* except for resize in lower right corner *) + IF (c.opts * {pageWidth..winHeight} # {}) + OR (msg.x < r) OR (msg.y < b) THEN RETURN END + END + ELSE + END + END; + c.HandleCtrlMsg^(f, msg, focus) + END HandleCtrlMsg; + + + PROCEDURE (c: Controller) PasteChar (ch: CHAR); + END PasteChar; + + PROCEDURE (c: Controller) ControlChar (f: Views.Frame; ch: CHAR); + END ControlChar; + + PROCEDURE (c: Controller) ArrowChar (f: Views.Frame; ch: CHAR; units, select: BOOLEAN); + END ArrowChar; + + PROCEDURE (c: Controller) CopyLocalSelection (src, dst: Views.Frame; sx, sy, dx, dy: INTEGER); + END CopyLocalSelection; + + + (* StdContext *) + + PROCEDURE (c: StdContext) ThisModel (): Models.Model; + BEGIN + RETURN c.model + END ThisModel; + + PROCEDURE (c: StdContext) GetSize (OUT w, h: INTEGER); + VAR m: Model; dc: Models.Context; l, t, r, b: INTEGER; + BEGIN + m := c.model; + m.doc.PollRect(l, t, r, b); w := r - l; h := b - t; + dc := m.doc.context; + IF dc # NIL THEN + WITH dc: PrinterContext DO + w := MIN(w, dc.r - dc.l); h := MIN(h, dc.b - dc.t) + ELSE + END + END; + ASSERT(w > 0, 60); ASSERT(h > 0, 61) + END GetSize; + + PROCEDURE (c: StdContext) SetSize (w, h: INTEGER); + VAR m: Model; d: StdDocument; minW, maxW, minH, maxH, defW, defH: INTEGER; + BEGIN + m := c.model; d := m.doc; ASSERT(d # NIL, 20); + m.GetEmbeddingLimits(minW, maxW, minH, maxH); + defW := m.r - m.l; defH := m.b - m.t; + Properties.PreferredSize(m.view, minW, maxW, minH, maxH, defW, defH, w, h); + d.SetRect(m.l, m.t, m.l + w, m.t + h) + END SetSize; + + PROCEDURE (c: StdContext) Normalize (): BOOLEAN; + BEGIN + RETURN TRUE + END Normalize; + + PROCEDURE (c: StdContext) ThisDoc (): Document; + BEGIN + RETURN c.model.doc + END ThisDoc; + + PROCEDURE (c: StdContext) MakeVisible (l, t, r, b: INTEGER); + BEGIN + MakeVisible(c.model.doc, NIL, l, t, r, b) + END MakeVisible; + + + (* PrinterContext *) + + PROCEDURE (c: PrinterContext) GetSize (OUT w, h: INTEGER); + VAR p: Ports.Port; + BEGIN + p := c.pr.ThisPort(); + p.GetSize(w, h); + w := w * p.unit; + h := h * p.unit + END GetSize; + + PROCEDURE (c: PrinterContext) Normalize (): BOOLEAN; + BEGIN + RETURN TRUE + END Normalize; + + PROCEDURE (c: PrinterContext) SetSize (w, h: INTEGER); + END SetSize; + + PROCEDURE (c: PrinterContext) ThisModel (): Models.Model; + BEGIN + RETURN NIL + END ThisModel; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (view: Views.View; w, h: INTEGER): Document; + VAR doc: StdDocument; m: Model; c: Controller; + BEGIN + ASSERT(view # NIL, 20); ASSERT(~(view IS Document), 21); + NEW(m); + NEW(doc); doc.InitModel(m); + NEW(c); doc.SetController(c); + doc.SetRect(defB, defB, defB + 1, defB + 1); (* set top-left point *) + doc.SetView(view, w, h); (* joins store graphs of doc and view *) + Stores.InitDomain(doc); (* domains of new documents are bound *) + RETURN doc + END New; + + + (** PContext **) + + PROCEDURE (c: PContext) GetSize (OUT w, h: INTEGER); + BEGIN + w := c.w; h := c.h + END GetSize; + + PROCEDURE (c: PContext) Normalize (): BOOLEAN; + BEGIN + RETURN TRUE + END Normalize; + + PROCEDURE (c: PContext) SetSize (w, h: INTEGER); + END SetSize; + + PROCEDURE (c: PContext) ThisModel (): Models.Model; + BEGIN + RETURN NIL + END ThisModel; + + + (** Pager **) + + + PROCEDURE (p: Pager) Restore (f: Views.Frame; l, t, r, b: INTEGER); + BEGIN + Views.InstallFrame(f, p.con.view, -p.x, -p.y, 0, FALSE) + END Restore; + + PROCEDURE (p: Pager) HandleCtrlMsg (f: Views.Frame; VAR msg: Views.CtrlMessage; VAR focus: Views.View); + VAR v: Views.View; g: Views.Frame; + BEGIN + WITH msg: Controllers.PageMsg DO + v := p.con.view; g := Views.ThisFrame(f, v); + IF g = NIL THEN + Views.InstallFrame(f, v, 0, 0, 0, FALSE); + g := Views.ThisFrame(f, v) + END; + IF g # NIL THEN + Views.ForwardCtrlMsg(g, msg); + IF ~msg.done THEN + IF p.con.w > p.w THEN (* needs horizontal paging *) + IF msg.op = Controllers.gotoPageX THEN p.x := msg.pageX * p.w; msg.done := TRUE + ELSIF msg.op = Controllers.nextPageX THEN p.x := p.x + p.w; msg.done := TRUE + END; + IF p.x >= p.con.w THEN msg.eox := TRUE; p.x := 0 END + END; + IF p.con.h > p.h THEN (* needs vertical paging *) + IF msg.op = Controllers.gotoPageY THEN p.y := msg.pageY * p.h; msg.done := TRUE + ELSIF msg.op = Controllers.nextPageY THEN p.y := p.y + p.h; msg.done := TRUE + END; + IF p.y >= p.con.h THEN msg.eoy := TRUE; p.y := 0 END + END + END + END + ELSE focus := p.con.view + END + END HandleCtrlMsg; + + PROCEDURE NewPager (v: Views.View; w, h, pw, ph: INTEGER): Pager; + VAR p: Pager; c: PContext; + BEGIN + NEW(c); c.view := v; c.w := w; c.h := h; v.InitContext(c); + NEW(p); p.con := c; p.w := pw; p.h := ph; p.x := 0; p.y := 0; + Stores.Join(v, p); + RETURN p + END NewPager; + + PROCEDURE PrinterDoc (d: Document; c: PrinterContext): Document; + VAR v, u, p: Views.View; w, h, l, t, r, b, pw, ph: INTEGER; pd: Document; + ct: Containers.Controller; dec: BOOLEAN; seq: ANYPTR; + BEGIN + v := d.ThisView(); + + IF d.Domain() # NIL THEN seq:=d.Domain().GetSequencer(); + IF seq#NIL THEN seq(Sequencers.Sequencer).BeginModification(Sequencers.invisible, d) END + END; + u := Views.CopyOf(v, Views.shallow); + IF d.Domain() # NIL THEN seq:=d.Domain().GetSequencer(); + IF seq#NIL THEN seq(Sequencers.Sequencer).EndModification(Sequencers.invisible, d) END + END; + + d.PollPage(w, h, l, t, r, b, dec); pw := r - l; ph := b - t; (* page size *) + v.context.GetSize(w, h); + ct := d.ThisController(); + IF winWidth IN ct.opts THEN w := pw END; (* fit to win -> fit to page *) + IF winHeight IN ct.opts THEN h := ph END; + p := NewPager(u, w, h, pw, ph); + ASSERT(Stores.Joined(p, d), 100); + pd := dir.New(p, pw, ph); + pd.InitContext(c); + RETURN pd + END PrinterDoc; + + + (** miscellaneous **) + + PROCEDURE Print* (d: Document; p: Printers.Printer; par: Printing.Par); + VAR dom: Stores.Domain; d1: Document; f: Views.RootFrame; g: Views.Frame; + c: PrinterContext; from, to, this, copies, w, h, u, k: INTEGER; page: Controllers.PageMsg; + title: Views.Title; port: Ports.Port; + BEGIN + ASSERT(d # NIL, 20); ASSERT(p # NIL, 21); + ASSERT(par # NIL, 22); + ASSERT(par.page.from >= 0, 23); ASSERT(par.page.from <= par.page.to, 24); + ASSERT(par.copies > 0, 25); + IF (par.header.right # "") OR (par.page.alternate & (par.header.left # "")) THEN + ASSERT(par.header.font # NIL, 26) + END; + IF (par.footer.right # "") OR (par.page.alternate & (par.footer.left # "")) THEN + ASSERT(par.footer.font # NIL, 27) + END; + IF par.page.title = "" THEN title := "(" + Dialog.appName + ")" ELSE title := par.page.title END; + from := par.page.from; to := par.page.to; + copies := par.copies; + CheckOrientation(d, p); + p.OpenJob(copies, title); + IF p.res = 0 THEN + dom := d.Domain(); + ASSERT(dom # NIL, 100); + c := NewPrinterContext(d, p, par); + d1 := PrinterDoc(d, c); + CheckOrientation(d, p); (* New in PrinterDoc resets printer orientation *) + d1.GetNewFrame(g); f := g(Views.RootFrame); f.ConnectTo(p.ThisPort()); + Views.SetRoot(f, d1, FALSE, {}); Views.AdaptRoot(f); + current := 0; (*par.page.current := 0; *) + d1.Restore(f, 0, 0, 0, 0); (* install frame for doc's view *) + Kernel.PushTrapCleaner(cleaner); + port := p.ThisPort(); + Printing.par := par; + page.op := Controllers.gotoPageX; page.pageX := 0; + page.done := FALSE; page.eox := FALSE; + Views.ForwardCtrlMsg(f, page); + IF page.done THEN this := 0 ELSE this := from END; + page.op := Controllers.gotoPageY; page.pageY := this; + page.done := FALSE; page.eoy := FALSE; + Views.ForwardCtrlMsg(f, page); + IF ~page.done & (from > 0) OR page.eox OR page.eoy THEN to := -1 END; + WHILE this <= to DO + IF this >= from THEN + current := this; (*par.page.current := this;*) + port.GetSize(w, h); u := port.unit; + FOR k := copies TO par.copies DO + p.OpenPage; + IF p.res = 0 THEN + Views.RemoveFrames(f, 0, 0, w * u, h * u); + Views.RestoreRoot(f, 0, 0, w * u, h * u) + END; + p.ClosePage + END + END; + IF p.res # abort THEN INC(this) ELSE to := -1 END; + IF this <= to THEN + page.op := Controllers.nextPageX; + page.done := FALSE; page.eox := FALSE; + Views.ForwardCtrlMsg(f, page); + IF ~page.done OR page.eox THEN + IF page.done THEN + page.op := Controllers.gotoPageX; page.pageX := 0; + page.done := FALSE; page.eox := FALSE; + Views.ForwardCtrlMsg(f, page) + END; + page.op := Controllers.nextPageY; + page.done := FALSE; page.eoy := FALSE; + Views.ForwardCtrlMsg(f, page); + IF ~page.done OR page.eoy THEN to := -1 END + END + END + END; + Printing.par := NIL; + Kernel.PopTrapCleaner(cleaner) + ELSE Dialog.ShowMsg("#System:FailedToOpenPrintJob") + END; + p.CloseJob + END Print; + + PROCEDURE (hook: PrintingHook) Current(): INTEGER; + BEGIN + RETURN current + END Current; + + PROCEDURE (hook: PrintingHook) Print (v: Views.View; par: Printing.Par); + VAR dom: Stores.Domain; d: Document; f: Views.RootFrame; c: PrinterContext; + w, h, u: INTEGER; p: Printers.Printer; g: Views.Frame; title: Views.Title; + k, copies: INTEGER; port: Ports.Port; + BEGIN + ASSERT(v # NIL, 20); + p := Printers.dir.Current(); + ASSERT(p # NIL, 21); + IF v IS Document THEN Print(v(Document), p, par); RETURN END; + IF (v.context # NIL) & (v.context IS Context) THEN + Print(v.context(Context).ThisDoc(), p, par); RETURN + END; + p.SetOrientation(FALSE); + IF par.page.title = "" THEN title := "(" + Dialog.appName + ")" ELSE title := par.page.title END; + copies := par.copies; + p.OpenJob(copies, title); + IF p.res = 0 THEN + Printing.par := par; + Stores.InitDomain(v); + dom := v.Domain(); + v := Views.CopyOf(v, Views.shallow) ; + d := dir.New(v, Views.undefined, Views.undefined); + c := NewPrinterContext(d, (* dom, *) p, par); + d.InitContext(c); (* Stores.InitDomain(d, c.Domain()); (* nicht mehr noetig *) *) + d.GetNewFrame(g); f := g(Views.RootFrame); + port := p.ThisPort(); f.ConnectTo(port); + Views.SetRoot(f, d, FALSE, {}); Views.AdaptRoot(f); + port.GetSize(w, h); u := port.unit; + FOR k := copies TO par.copies DO + p.OpenPage; + IF p.res = 0 THEN + Views.RemoveFrames(f, 0, 0, w * u, h * u); Views.RestoreRoot(f, 0, 0, w * u, h * u) + END; + p.ClosePage + END + END; + Printing.par := NIL; + p.CloseJob + END Print; + + + PROCEDURE ImportDocument* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; tag, version: INTEGER; + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); + r.ReadInt(tag); + IF tag = docTag THEN + r.ReadInt(version); + ASSERT(version = docVersion, 100); + r.ReadStore(s); + IF s IS Document THEN s := s(Document).ThisView() + ELSE s := NIL + END + END + END ImportDocument; + + PROCEDURE ExportDocument* (s: Stores.Store; f: Files.File); + VAR w: Stores.Writer; v: Views.View; + BEGIN + ASSERT(s # NIL, 20); + ASSERT(s IS Views.View, 21); + ASSERT(f # NIL, 22); + v := s(Views.View); + IF (v.context # NIL) & (v.context IS Context) THEN + v := v.context(Context).ThisDoc() + END; + IF ~(v IS Document) THEN + IF v.context # NIL THEN + v := Views.CopyOf(v, Views.shallow) + END; + v := dir.New(v, Views.undefined, Views.undefined) + END; + w.ConnectTo(f); + w.WriteInt(docTag); w.WriteInt(docVersion); + w.WriteStore(v) + END ExportDocument; + + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d; + IF stdDir = NIL THEN stdDir := d END + END SetDir; + + PROCEDURE Init; + VAR d: StdDirectory; h: PrintingHook; + BEGIN + NEW(d); SetDir(d); + NEW(h); Printing.SetHook(h); + NEW(cleaner) + END Init; + +BEGIN + Init +END Documents. diff --git a/Trurl-based/System/Mod/Files.txt b/Trurl-based/System/Mod/Files.txt new file mode 100644 index 0000000..59d373e --- /dev/null +++ b/Trurl-based/System/Mod/Files.txt @@ -0,0 +1,110 @@ +MODULE Files; + + (* THIS IS TEXT COPY OF BlackBox-1.6 System/Mod/Files.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel; + + CONST + shared* = TRUE; exclusive* = FALSE; + dontAsk* = FALSE; ask* = TRUE; (** File.Register, Directory.New and Directory.Rename **) + + CONST + readOnly* = 0; + hidden* = 1; + system* = 2; + archive* = 3; + stationery* = 4; + + TYPE + Name* = ARRAY 256 OF CHAR; + Type* = ARRAY 16 OF CHAR; + + FileInfo* = POINTER TO RECORD + next*: FileInfo; + name*: Name; + length*: INTEGER; + type*: Type; + modified*: RECORD year*, month*, day*, hour*, minute*, second*: INTEGER END; + attr*: SET + END; + + LocInfo* = POINTER TO RECORD + next*: LocInfo; + name*: Name; + attr*: SET; + END; + + Locator* = POINTER TO ABSTRACT RECORD + res*: INTEGER; + END; + + File* = POINTER TO ABSTRACT RECORD + type-: Type; + init: BOOLEAN; + END; + + Reader* = POINTER TO ABSTRACT RECORD + eof*: BOOLEAN; + END; + + Writer* = POINTER TO ABSTRACT RECORD END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + VAR dir-, stdDir-: Directory; + objType-, symType-, docType- : Type; (* file types *) + + + PROCEDURE (l: Locator) This* (IN path: ARRAY OF CHAR): Locator, NEW, ABSTRACT; + + PROCEDURE (f: File) InitType* (type: Type), NEW; + BEGIN + ASSERT(~f.init, 20); + f.type := type$; f.init := TRUE + END InitType; + + PROCEDURE (f: File) Length* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (f: File) NewReader* (old: Reader): Reader, NEW, ABSTRACT; + PROCEDURE (f: File) NewWriter* (old: Writer): Writer, NEW, ABSTRACT; + PROCEDURE (f: File) Flush* (), NEW, ABSTRACT; + PROCEDURE (f: File) Register* (name: Name; type: Type; ask: BOOLEAN; + OUT res: INTEGER), NEW, ABSTRACT; + PROCEDURE (f: File) Close* (), NEW, ABSTRACT; + + PROCEDURE (r: Reader) Base* (): File, NEW, ABSTRACT; + PROCEDURE (r: Reader) Pos* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (r: Reader) SetPos* (pos: INTEGER), NEW, ABSTRACT; + PROCEDURE (r: Reader) ReadByte* (OUT x: BYTE), NEW, ABSTRACT; + PROCEDURE (r: Reader) ReadBytes* (VAR x: ARRAY OF BYTE; beg, len: INTEGER), NEW, ABSTRACT; + + PROCEDURE (w: Writer) Base* (): File, NEW, ABSTRACT; + PROCEDURE (w: Writer) Pos* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (w: Writer) SetPos* (pos: INTEGER), NEW, ABSTRACT; + PROCEDURE (w: Writer) WriteByte* (x: BYTE), NEW, ABSTRACT; + PROCEDURE (w: Writer) WriteBytes* (IN x: ARRAY OF BYTE; beg, len: INTEGER), NEW, ABSTRACT; + + PROCEDURE (d: Directory) This* (IN path: ARRAY OF CHAR): Locator, NEW, ABSTRACT; + PROCEDURE (d: Directory) New* (loc: Locator; ask: BOOLEAN): File, NEW, ABSTRACT; + PROCEDURE (d: Directory) Old* (loc: Locator; name: Name; shared: BOOLEAN): File, NEW, ABSTRACT; + PROCEDURE (d: Directory) Temp* (): File, NEW, ABSTRACT; + PROCEDURE (d: Directory) Delete* (loc: Locator; name: Name), NEW, ABSTRACT; + PROCEDURE (d: Directory) Rename* (loc: Locator; old, new: Name; ask: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (d: Directory) SameFile* (loc0: Locator; name0: Name; loc1: Locator; + name1: Name): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (d: Directory) FileList* (loc: Locator): FileInfo, NEW, ABSTRACT; + PROCEDURE (d: Directory) LocList* (loc: Locator): LocInfo, NEW, ABSTRACT; + PROCEDURE (d: Directory) GetFileName* (name: Name; type: Type; OUT filename: Name), NEW, ABSTRACT; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d; + IF stdDir = NIL THEN stdDir := d END + END SetDir; + +BEGIN + objType := Kernel.objType; + symType := Kernel.symType; + docType := Kernel.docType; +END Files. diff --git a/Trurl-based/System/Mod/Fonts.txt b/Trurl-based/System/Mod/Fonts.txt new file mode 100644 index 0000000..e97e6ba --- /dev/null +++ b/Trurl-based/System/Mod/Fonts.txt @@ -0,0 +1,59 @@ +MODULE Fonts; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Fonts.odc *) + (* DO NOT EDIT *) + + CONST + (** universal units **) + mm* = 36000; + point* = 12700; (** 1/72 inch **) + + italic* = 0; underline* = 1; strikeout* = 2; (** style elements **) + + normal* = 400; bold* = 700; + + default* = "*"; + + TYPE + Typeface* = ARRAY 64 OF CHAR; + + Font* = POINTER TO ABSTRACT RECORD + typeface-: Typeface; + size-: INTEGER; + style-: SET; + weight-: INTEGER + END; + + TypefaceInfo* = POINTER TO RECORD + next*: TypefaceInfo; + typeface*: Typeface + END; + + Directory* = POINTER TO ABSTRACT RECORD + END; + + VAR dir-: Directory; + + PROCEDURE (f: Font) Init* (typeface: Typeface; size: INTEGER; style: SET; weight: INTEGER), NEW; + BEGIN + ASSERT(f.size = 0, 20); ASSERT(size # 0, 21); + f.typeface := typeface$; f.size := size; f.style := style; f.weight := weight + END Init; + + PROCEDURE (f: Font) GetBounds* (OUT asc, dsc, w: INTEGER), NEW, ABSTRACT; + PROCEDURE (f: Font) StringWidth* (IN s: ARRAY OF CHAR): INTEGER, NEW, ABSTRACT; + PROCEDURE (f: Font) SStringWidth* (IN s: ARRAY OF SHORTCHAR): INTEGER, NEW, ABSTRACT; + PROCEDURE (f: Font) IsAlien* (): BOOLEAN, NEW, ABSTRACT; + + PROCEDURE (d: Directory) This* (typeface: Typeface; size: INTEGER; style: SET; weight: INTEGER): Font, NEW, ABSTRACT; + PROCEDURE (d: Directory) Default* (): Font, NEW, ABSTRACT; + PROCEDURE (d: Directory) TypefaceList* (): TypefaceInfo, NEW, ABSTRACT; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d + END SetDir; + +END Fonts. + diff --git a/Trurl-based/System/Mod/In.txt b/Trurl-based/System/Mod/In.txt new file mode 100644 index 0000000..2d5f7a0 --- /dev/null +++ b/Trurl-based/System/Mod/In.txt @@ -0,0 +1,87 @@ +MODULE In; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/In.odc *) + (* DO NOT EDIT *) + + IMPORT TextMappers, TextControllers; + + VAR + Done-: BOOLEAN; + s: TextMappers.Scanner; + + PROCEDURE Open*; + VAR c: TextControllers.Controller; beg, end: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := 0 END; + s.ConnectTo(c.text); s.SetPos(beg); s.rider.Read; Done := TRUE + ELSE + s.ConnectTo(NIL); Done := FALSE + END + END Open; + + PROCEDURE Char* (OUT ch: CHAR); + BEGIN + IF Done THEN + IF s.rider.eot THEN Done := FALSE + ELSE ch := s.rider.char; s.rider.Read + END + END + END Char; + + PROCEDURE Int* (OUT i: INTEGER); + BEGIN + IF Done THEN + s.Scan; + IF (s.type = TextMappers.int) THEN + i := s.int + ELSE Done := FALSE + END + END + END Int; + + PROCEDURE LongInt* (OUT l: LONGINT); + BEGIN + IF Done THEN + s.Scan; + IF (s.type = TextMappers.lint) OR (s.type = TextMappers.int) THEN + l := s.lint + ELSE Done := FALSE + END + END + END LongInt; + + PROCEDURE Real* (OUT x: REAL); + BEGIN + IF Done THEN + s.Scan; + IF s.type = TextMappers.real THEN + x := SHORT(s.real) + ELSIF s.type = TextMappers.int THEN + x := s.int + ELSE Done := FALSE + END + END + END Real; + + PROCEDURE Name* (OUT name: ARRAY OF CHAR); + BEGIN + IF Done THEN + s.Scan; + TextMappers.ScanQualIdent(s, name, Done) + END + END Name; + + PROCEDURE String* (OUT str: ARRAY OF CHAR); + BEGIN + IF Done THEN + s.Scan; + IF s.type = TextMappers.string THEN + str := s.string$ + ELSE Done := FALSE + END + END + END String; + +END In. diff --git a/Trurl-based/System/Mod/Integers.txt b/Trurl-based/System/Mod/Integers.txt new file mode 100644 index 0000000..570eb37 --- /dev/null +++ b/Trurl-based/System/Mod/Integers.txt @@ -0,0 +1,848 @@ +MODULE Integers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Integers.odc *) + (* DO NOT EDIT *) + + IMPORT Files, Math; + + CONST + B = 10000; DecPerDig = 4; BinBase = 16 * 1024; + KaratsubaBreak = 41; + + TYPE + Index = INTEGER; + Digit = SHORTINT; + DoubleDigit = INTEGER; + + IntegerDesc = ARRAY OF Digit; (* to hide internal structure from interface *) + Integer* = POINTER TO IntegerDesc; + Buffer = RECORD + digit: Integer; + beg, len: Index + END; + + VAR zero, one, two, buf6: Integer; + + PROCEDURE CopyOf (x: Integer; len: Index): Integer; + VAR buf: Integer; + BEGIN + ASSERT(len > 0, 20); + NEW(buf, len); + REPEAT DEC(len); buf[len] := x[len] UNTIL len = 0; + RETURN buf + END CopyOf; + + (* Operations on Digits *) + + PROCEDURE Add (x, y, sum: Integer; xL, yL: Index; OUT sumL: Index); + VAR i, l: Index; c: Digit; + BEGIN + l := MIN(xL, yL); + i := 0; c := 0; + WHILE i < l DO c := SHORT(c DIV B + x[i] + y[i]); sum[i] := SHORT(c MOD B); INC(i) END; + WHILE i < xL DO c := SHORT(c DIV B + x[i]); sum[i] := SHORT(c MOD B); INC(i) END; + WHILE i < yL DO c := SHORT(c DIV B + y[i]); sum[i] := SHORT(c MOD B); INC(i) END; + IF c >= B THEN sum[i] := SHORT(c DIV B); INC(i) END; + sumL := i + END Add; + + PROCEDURE Subtract (x, y, dif: Integer; xL, yL: Index; OUT difL: Index); + VAR i: Index; c, d: Digit; + BEGIN + ASSERT(xL >= yL, 20); + i := 0; difL := 0; c := 0; + WHILE i < yL DO + c := SHORT(c DIV B + x[i] - y[i]); d := SHORT(c MOD B); + IF d # 0 THEN + WHILE difL # i DO dif[difL] := 0; INC(difL) END; + dif[i] := d; INC(difL) + END; + INC(i) + END; + WHILE i < xL DO + c := SHORT(c DIV B + x[i]); d := SHORT(c MOD B); + IF d # 0 THEN + WHILE difL # i DO dif[difL] := 0; INC(difL) END; + dif[i] := d; INC(difL) + END; + INC(i) + END; + ASSERT(c DIV B = 0, 100) + END Subtract; + + PROCEDURE OneDigitMult (a, b: Buffer; VAR c: Buffer); + VAR i: Index; carry, factor: DoubleDigit; + BEGIN + ASSERT(a.len = 1, 20); + factor := a.digit[a.beg]; i := 0; carry := 0; + WHILE i # b.len DO + carry := carry DIV B + factor * b.digit[b.beg + i]; c.digit[c.beg + i] := SHORT(carry MOD B); + INC(i) + END; + IF carry >= B THEN c.digit[c.beg + i] := SHORT(carry DIV B); INC(i) END; + c.len := i + END OneDigitMult; + + PROCEDURE SimpleMult (a, b: Buffer; VAR c: Buffer); + VAR i, j, k: Index; c0, c1: DoubleDigit; + BEGIN + ASSERT(a.len <= b.len, 20); + c.len := a.len + b.len - 1; + i := 0; c0 := 0; c1 := 0; + REPEAT + IF i < b.len THEN + IF i < a.len THEN j := i; k := 0 ELSE j := a.len - 1; k := i - a.len + 1 END; + REPEAT + c0 := c0 + a.digit[a.beg + j] * b.digit[b.beg + k]; + IF c0 > MAX(DoubleDigit) - BinBase * (B - 1) THEN + c1 := c1 + c0 DIV BinBase; c0 := c0 MOD BinBase + END; + DEC(j); INC(k) + UNTIL j < 0 + ELSE + j := a.len - 1; k := i - a.len + 1; + REPEAT + c0 := c0 + a.digit[a.beg + j] * b.digit[b.beg + k]; + IF c0 > MAX(DoubleDigit) - BinBase * (B - 1) THEN + c1 := c1 + c0 DIV BinBase; c0 := c0 MOD BinBase + END; + DEC(j); INC(k) + UNTIL k = b.len + END; + IF c1 = 0 THEN c.digit[c.beg + i] := SHORT(c0 MOD B); c0 := c0 DIV B + ELSE + c0 := c0 + BinBase * (c1 MOD B); + c.digit[c.beg + i] := SHORT(c0 MOD B); c0 := c0 DIV B; c1 := c1 DIV B + END; + INC(i) + UNTIL i = c.len; + IF c0 # 0 THEN c.digit[c.beg + c.len] := SHORT(c0); INC(c.len) END + END SimpleMult; + + PROCEDURE AddBuf (a, b: Buffer; VAR c: Buffer); (* c := a + b *) + VAR i: Index; carry: Digit; + BEGIN + ASSERT(a.len <= b.len, 20); + i := 0; carry := 0; + WHILE i # a.len DO + carry := SHORT(carry DIV B + a.digit[a.beg + i] + b.digit[b.beg + i]); + c.digit[c.beg + i] := SHORT(carry MOD B); + INC(i) + END; + WHILE (i # b.len) & (carry >= B) DO + carry := SHORT(carry DIV B + b.digit[b.beg + i]); c.digit[c.beg + i] := SHORT(carry MOD B); + INC(i) + END; + IF carry >= B THEN c.digit[c.beg + i] := SHORT(carry DIV B); INC(i) + ELSE + WHILE i # b.len DO c.digit[c.beg + i] := b.digit[b.beg + i]; INC(i) END + END; + c.len := i + END AddBuf; + + PROCEDURE AddToBuf (VAR a: Buffer; b: Buffer; shift: Index); (* a := a + b * B^shift *) + VAR i, n: Index; carry: Digit; + BEGIN + b.beg := b.beg - shift; b.len := b.len + shift; i := shift; n := MIN(a.len, b.len); carry := 0; + WHILE i # n DO + carry := SHORT(carry DIV B + a.digit[a.beg + i] + b.digit[b.beg + i]); + a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + IF i # a.len THEN + WHILE (i # a.len) & (carry >= B) DO + carry := SHORT(carry DIV B + a.digit[a.beg + i]); a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + IF carry >= B THEN a.digit[a.beg + i] := SHORT(carry DIV B); INC(i) END + ELSE + WHILE (i # b.len) & (carry >= B) DO + carry := SHORT(carry DIV B + b.digit[b.beg + i]); a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + IF carry >= B THEN a.digit[a.beg + i] := SHORT(carry DIV B); INC(i) + ELSE + WHILE i # b.len DO a.digit[a.beg + i] := b.digit[b.beg + i]; INC(i) END + END + END; + a.len := MAX(i, a.len) + END AddToBuf; + + PROCEDURE SubtractFromBuf (VAR a: Buffer; b, c: Buffer); (* a := a - b - c *) + VAR i: Index; carry: Digit; + BEGIN + ASSERT(b.len <= c.len, 20); + i := 0; carry := 0; + WHILE i # b.len DO + carry := SHORT(carry DIV B + a.digit[a.beg + i] - b.digit[b.beg + i] - c.digit[c.beg + i]); + a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + WHILE i # c.len DO + carry := SHORT(carry DIV B + a.digit[a.beg + i] - c.digit[c.beg + i]); + a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + WHILE carry < 0 DO + carry := SHORT(carry DIV B + a.digit[a.beg + i]); a.digit[a.beg + i] := SHORT(carry MOD B); + INC(i) + END; + ASSERT(i <= a.len, 100); + WHILE (a.len # 0) & (a.digit[a.beg + a.len - 1] = 0) DO DEC(a.len) END + END SubtractFromBuf; + + PROCEDURE KStep (a, b: Buffer; VAR c: Buffer; stack: Buffer); + VAR n2, i: Index; a0, a1, b0, b1, c0, c1, h: Buffer; + BEGIN + ASSERT(a.len <= b.len, 20); + IF a.len = 0 THEN c.len := 0 + ELSIF a.len = 1 THEN OneDigitMult(a, b, c) + ELSIF a.len <= KaratsubaBreak THEN SimpleMult(a, b, c) + ELSE + n2 := b.len DIV 2; + c0.digit := c.digit; c0.beg := c.beg; c1.digit := c.digit; c1.beg := c.beg + 2 * n2; + a0.digit := a.digit; a0.beg := a.beg; a0.len := MIN(a.len, n2); + a1.digit := a.digit; a1.beg := a.beg + n2; a1.len := MAX(0, a.len - n2); + WHILE (a0.len # 0) & (a0.digit[a0.beg + a0.len - 1] = 0) DO DEC(a0.len) END; + b0.digit := b.digit; b0.beg := b.beg; b0.len := MIN(b.len, n2); + b1.digit := b.digit; b1.beg := b.beg + n2; b1.len := MAX(0, b.len - n2); + WHILE (b0.len # 0) & (b0.digit[b0.beg + b0.len - 1] = 0) DO DEC(b0.len) END; + IF (a0.len # 0) OR (b0.len # 0) THEN + IF a0.len <= a1.len THEN AddBuf(a0, a1, c1) ELSE AddBuf(a1, a0, c1) END; + IF b0.len <= b1.len THEN AddBuf(b0, b1, c0) ELSE AddBuf(b1, b0, c0) END; + h.digit := stack.digit; h.beg := stack.beg; stack.beg := stack.beg + c0.len + c1.len; + IF c0.len <= c1.len THEN KStep(c0, c1, h, stack) ELSE KStep(c1, c0, h, stack) END; + IF a0.len <= b0.len THEN KStep(a0, b0, c0, stack) ELSE KStep(b0, a0, c0, stack) END; + KStep(a1, b1, c1, stack); + IF c0.len <= c1.len THEN SubtractFromBuf(h, c0, c1) ELSE SubtractFromBuf(h, c1, c0) END; + IF c1.len # 0 THEN + i := c0.beg + c0.len; + WHILE i < c1.beg DO c.digit[i] := 0; INC(i) END; + c.len := c1.beg + c1.len - c.beg + ELSE + WHILE c0.len < n2 DO c0.digit[c0.beg + c0.len] := 0; INC(c0.len) END; + c.len := c0.len + END; + ASSERT(h.len # 0, 100); + AddToBuf(c, h, n2) + ELSE + KStep(a1, b1, c1, stack); c.len := c1.beg + c1.len - c.beg; + i := c.beg; + WHILE i # c1.beg DO c.digit[i] := 0; INC(i) END + END + END + END KStep; + + PROCEDURE Karatsuba (x, y, pro:Integer; xL, yL: Index; OUT proL: Index); + VAR a, b, c, stack: Buffer; + BEGIN + ASSERT(xL <= yL, 20); + a.digit := x; a.beg := 0; a.len := xL; b.digit := y; b.beg := 0; b.len := yL; + c.digit := pro; c.beg := 0; + NEW(stack.digit, 2 * b.len); stack.beg := 0; + KStep(a, b, c, stack); + proL := c.len + END Karatsuba; + + PROCEDURE Multiply (x, y, pro: Integer; xL, yL: Index; OUT proL: Index); + VAR i, j, k: Index; c0, c1: DoubleDigit; + BEGIN + ASSERT(xL <= yL, 20); + IF xL > KaratsubaBreak THEN Karatsuba(x, y, pro, xL, yL, proL) + ELSIF xL = 1 THEN + proL := 0; c1 := x[0]; c0 := 0; + WHILE proL < yL DO + c0 := c1 * y[proL] + c0; pro[proL] := SHORT(c0 MOD B); + c0 := c0 DIV B ; INC(proL) + END; + IF c0 # 0 THEN pro[proL] := SHORT(c0); INC(proL) END + ELSE + proL := xL + yL - 1; + i := 0; c0 := 0; c1 := 0; + REPEAT + IF i < yL THEN + IF i < xL THEN j := i; k := 0 ELSE j := xL - 1; k := i - xL + 1 END; + REPEAT + c0 := c0 + x[j] * y[k]; + IF c0 > MAX(DoubleDigit) - BinBase * (B - 1) THEN + c1 := c1 + c0 DIV BinBase; c0 := c0 MOD BinBase + END; + DEC(j); INC(k) + UNTIL j < 0 + ELSE + j := xL - 1; k := i - xL + 1; + REPEAT + c0 := c0 + x[j] * y[k]; + IF c0 > MAX(DoubleDigit) - BinBase * (B - 1) THEN + c1 := c1 + c0 DIV BinBase; c0 := c0 MOD BinBase + END; + DEC(j); INC(k) + UNTIL k = yL + END; + IF c1 = 0 THEN pro[i] := SHORT(c0 MOD B); c0 := c0 DIV B + ELSE c0 := c0 + BinBase * (c1 MOD B); pro[i] := SHORT(c0 MOD B); + c0 := c0 DIV B; c1 := c1 DIV B + END; + INC(i) + UNTIL i = proL; + IF c0 # 0 THEN pro[proL] := SHORT(c0); INC(proL) END + END + END Multiply; + + PROCEDURE DecomposeQuoRem (x, y: Integer; xL, yL: Index); + VAR ix, iy, j: Index; d, q, h, yLead, ySecond: DoubleDigit; yBuf: Integer; + BEGIN + ASSERT((yL # 0) & (y[yL - 1] # 0), 20); + IF yL = 1 THEN + j := xL - 1; h := 0; d := y[0]; + WHILE j >= 0 DO h := x[j] + h * B; x[j + 1] := SHORT(h DIV d); h := h MOD d; DEC(j) END; + x[0] := SHORT(h) + ELSIF xL >= yL THEN + x[xL] := 0; d := (B DIV 2 - 1) DIV y[yL - 1] + 1; yBuf := CopyOf(y, yL); + IF d # 1 THEN + j := 0; h := 0; + WHILE j < xL DO h := d * x[j] + h DIV B; x[j] := SHORT(h MOD B); INC(j) END; + x[xL] := SHORT(h DIV B); + j := 0; h := 0; + WHILE j < yL DO h := d * yBuf[j] + h DIV B; yBuf[j] := SHORT(h MOD B); INC(j) END; + ASSERT(h DIV B = 0, 100) + END; + yLead := yBuf[yL - 1]; ySecond := yBuf[yL - 2]; j := xL; + WHILE j >= yL DO + IF x[j] # yLead THEN q := (x[j] * B + x[j - 1]) DIV yLead ELSE q := B - 1 END; + WHILE ySecond * q > (x[j] * B + x[j - 1] - yLead * q) * B + x[j - 2] DO + DEC(q) + END; + ix := j - yL; iy := 0; h := 0; + WHILE iy < yL DO + h := x[ix] - q * yBuf[iy] + h DIV B; x[ix] := SHORT(h MOD B); INC(ix); INC(iy) + END; + IF (-x[j]) # (h DIV B) THEN + ix := j - yL; iy := 0; h := 0; + WHILE iy < yL DO + h := h DIV B + x[ix] + yBuf[iy]; x[ix] := SHORT(h MOD B); INC(ix); INC(iy) + END; + x[j] := SHORT(q - 1) + ELSE x[j] := SHORT(q) + END; + DEC(j) + END; + IF d # 1 THEN + j := yL; h := 0; + WHILE j # 0 DO DEC(j); h := h + x[j]; x[j] := SHORT(h DIV d); h := (h MOD d) * B END + END + END + END DecomposeQuoRem; + + PROCEDURE GetQuoRem (x, y: Integer; xL, yL: Index; xNeg, yNeg: BOOLEAN; + quo, rem: Integer; OUT quoL, remL: Index; OUT quoNeg, remNeg: BOOLEAN; + doQuo, doRem: BOOLEAN); + VAR i: Index; c: Digit; xBuf: Integer; + BEGIN + ASSERT(xL >= yL, 20); + xBuf := CopyOf(x, xL + 1); + DecomposeQuoRem(xBuf, y, xL, yL); + i := xL; + WHILE (i >= yL) & (xBuf[i] = 0) DO DEC(i) END; + quoL := i - yL + 1; + i := yL - 1; + WHILE (i >= 0) & (xBuf[i] = 0) DO DEC(i) END; + remL := i + 1; + IF doQuo THEN + quoNeg := xNeg # yNeg; + IF quoNeg & (remL # 0) THEN + i := 0; c := 1; + WHILE (i # quoL) & (c # 0) DO + c := SHORT(c + xBuf[i + yL]); quo[i] := SHORT(c MOD B); c := SHORT(c DIV B); + INC(i) + END; + IF c = 0 THEN + WHILE i # quoL DO quo[i] := xBuf[i + yL]; INC(i) END + ELSE quo[i] := c; INC(quoL) + END + ELSE + i := 0; + WHILE i # quoL DO quo[i] := xBuf[i + yL]; INC(i) END + END + END; + IF doRem THEN + remNeg := yNeg & (remL # 0); + IF (xNeg # yNeg) & (remL # 0) THEN Subtract(y, xBuf, rem, yL, remL, remL) + ELSE + i := 0; + WHILE i # remL DO rem[i] := xBuf[i]; INC(i) END + END + END + END GetQuoRem; + + PROCEDURE BinPower (x: Integer; exp: INTEGER; y: Integer; xL: Index; OUT yL: Index); + VAR zL: Index; b: INTEGER; z: Integer; + BEGIN + ASSERT(exp > 0, 20); ASSERT(xL # 0, 21); + b := 1; + WHILE 2 * b <= exp DO b := 2 * b END; + y[0] := 1; yL := 1; NEW(z, LEN(y^)); + (* y^b * x^exp = const.) & (2 * b > exp) *) + WHILE (exp # 0) OR (b # 1) DO + IF exp >= b THEN + exp := exp - b; + IF xL <= yL THEN Multiply(x, y, z, xL, yL, zL) ELSE Multiply(y, x, z, yL, xL, zL) END + ELSE b := b DIV 2; Multiply(y, y, z, yL, yL, zL) + END; + yL := zL; + REPEAT DEC(zL); y[zL] := z[zL] UNTIL zL = 0 + END + END BinPower; + + (* Data Format Support *) + + PROCEDURE New (nofDigits: Index): Integer; + VAR x: Integer; + BEGIN + NEW(x, nofDigits + 2); RETURN x + END New; + + PROCEDURE SetLength (x: Integer; len: Index; negative: BOOLEAN); + VAR low, high: Digit; + BEGIN + ASSERT(len >= 0, 20); ASSERT(~negative OR (len # 0), 21); + IF negative THEN len := -len END; + low := SHORT(len MOD 10000H - 8000H); high := SHORT(len DIV 10000H); + x[LEN(x^) - 1] := low; x[LEN(x^) - 2] := high + END SetLength; + + PROCEDURE GetLength (x: Integer; OUT len: Index; OUT negative: BOOLEAN); + VAR low, high: Digit; + BEGIN + low := x[LEN(x^) - 1]; high := x[LEN(x^) - 2]; + len := low + 8000H + high * 10000H; + negative := len < 0; len := ABS(len) + END GetLength; + + (* Exported Services *) + + PROCEDURE Long* (x: LONGINT): Integer; + VAR i: Index; negative: BOOLEAN; int: Integer; + BEGIN + IF x # 0 THEN + negative := x < 0; x := ABS(x); + int := New(5); i := 0; + REPEAT int[i] := SHORT(SHORT(x MOD B)); x := x DIV B; INC(i) UNTIL x = 0; + SetLength(int, i, negative) + ELSE int := zero + END; + RETURN int + END Long; + + PROCEDURE Short* (x: Integer): LONGINT; + VAR i: Index; res: LONGINT; negative: BOOLEAN; + BEGIN + res := 0; GetLength(x, i, negative); + WHILE i # 0 DO DEC(i); res := res * B + x[i] END; + IF negative THEN res := -res END; + RETURN res + END Short; + + PROCEDURE Entier* (x: REAL): Integer; + VAR mL, yL, i: Index; mx: REAL; ex: INTEGER; neg: BOOLEAN; y, z: Integer; + + PROCEDURE Inc(m: Integer; VAR mL: Index); + VAR i: Index; + BEGIN + i := 0; + WHILE m[i] = B - 1 DO m[i] := 0; INC(i) END; + INC(m[i]); + IF i = mL THEN INC(mL); m[mL] := 0 END + END Inc; + + PROCEDURE Double (m: Integer; VAR mL: Index); + VAR i: Index; c: Digit; + BEGIN + i := 0; c := 0; + WHILE i < mL DO + c := SHORT(c + m[i] * 2); m[i] := SHORT(c MOD B); c := SHORT(c DIV B); + INC(i) + END; + IF c # 0 THEN INC(mL); m[mL] := 0; m[i] := c END + END Double; + + BEGIN + IF (x >= 1) OR (x < 0) THEN + neg := x < 0; x := ABS(x); + mL := 0; buf6[0] := 0; mx := Math.Mantissa(x); ex := Math.Exponent(x); + WHILE (mx # 0) & (ex > 0) DO (* mx * 2^ex + m * 2^ex = const. *) + IF ENTIER(mx) = 1 THEN Inc(buf6, mL); mx := mx - 1 + ELSE ASSERT(ENTIER(mx) = 0, 100) + END; + Double(buf6, mL); mx := 2 * mx; DEC(ex) + END; + IF (ENTIER(mx) = 1) & (ex = 0) THEN Inc(buf6, mL); mx := mx - 1 END; + IF ex > 0 THEN + y := New(mL + SHORT(ENTIER(Math.Ln(2) * ex / Math.Ln(B)) + 1)); + z := New(SHORT(ENTIER(Math.Ln(2) * ex / Math.Ln(B)) + 1)); + BinPower(two, ex, z, 1, yL); + IF mL <= yL THEN Multiply(buf6, z, y, mL, yL, yL) ELSE Multiply(z, buf6, y, yL, mL, yL) END + ELSE + y := New(mL + 1); yL := mL; + i := 0; + WHILE i # mL DO y[i] := buf6[i]; INC(i) END + END; + IF neg & (mx # 0) THEN Inc(y, yL) END; + SetLength(y, yL, neg) + ELSE y := zero + END; + RETURN y + END Entier; + + PROCEDURE Float* (x: Integer): REAL; + VAR i: Index; y: REAL; negative: BOOLEAN; + BEGIN + y := 0; GetLength(x, i, negative); + WHILE i # 0 DO DEC(i); y := y * B + x[i] END; + IF negative THEN y := -y END; + RETURN y + END Float; + + PROCEDURE Sign* (x: Integer): INTEGER; + VAR len: Index; negative: BOOLEAN; + BEGIN + GetLength(x, len, negative); + IF len = 0 THEN RETURN 0 + ELSIF negative THEN RETURN -1 + ELSE RETURN 1 + END + END Sign; + + PROCEDURE Abs* (x: Integer): Integer; + VAR len: Index; negative: BOOLEAN; y: Integer; + BEGIN + GetLength(x, len, negative); + IF negative THEN + y := New(len); SetLength(y, len, FALSE); + REPEAT DEC(len); y[len] := x[len] UNTIL len = 0 + ELSE y := x + END; + RETURN y + END Abs; + + PROCEDURE Digits10Of* (x: Integer): INTEGER; + VAR i, n: Index; d: Digit; negative: BOOLEAN; + BEGIN + GetLength(x, n, negative); + IF n # 0 THEN + d := x[n - 1]; i := 0; + REPEAT INC(i); d := SHORT(d DIV 10) UNTIL d = 0; + n := DecPerDig * (n - 1) + i + END; + RETURN n + END Digits10Of; + + PROCEDURE ThisDigit10* (x: Integer; exp10: INTEGER): CHAR; + VAR i, n: Index; d: Digit; negative: BOOLEAN; + BEGIN + ASSERT(exp10 >= 0, 20); + GetLength(x, n, negative); i := exp10 DIV DecPerDig; + IF n > i THEN + d := x[i]; i := exp10 MOD DecPerDig; + WHILE i # 0 DO d := SHORT(d DIV 10); DEC(i) END; + d := SHORT(d MOD 10) + ELSE d := 0 + END; + RETURN CHR(ORD("0") + d) + END ThisDigit10; + + PROCEDURE Compare* (x, y: Integer): INTEGER; + VAR xL, yL: Index; res: INTEGER; xNeg, yNeg: BOOLEAN; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); + IF xNeg = yNeg THEN + IF (xL = yL) & (xL # 0) THEN + DEC(xL); + WHILE (xL # 0) & (x[xL] = y[xL]) DO DEC(xL) END; + IF x[xL] = y[xL] THEN res := 0 ELSIF (x[xL] < y[xL]) = xNeg THEN res := 1 ELSE res := -1 END + ELSE + IF xL = yL THEN res := 0 ELSIF (xL < yL) = xNeg THEN res := 1 ELSE res := -1 END + END + ELSIF xNeg THEN res := -1 + ELSE res := 1 + END; + RETURN res + END Compare; + + PROCEDURE AddOp (x, y: Integer; subtract: BOOLEAN): Integer; + VAR i, d, xL, yL, intL: Index; xNeg, yNeg: BOOLEAN; int: Integer; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); + IF yL = 0 THEN int := x + ELSIF xL = 0 THEN + IF subtract THEN + int := New(yL); SetLength(int, yL, ~yNeg); + REPEAT DEC(yL); int[yL] := y[yL] UNTIL yL = 0 + ELSE int := y + END + ELSIF (xNeg = yNeg) # subtract THEN + int := New(MAX(xL, yL) + 1); Add(x, y, int, xL, yL, intL); SetLength(int, intL, xNeg) + ELSE + d := xL - yL; + IF d # 0 THEN i := MAX(xL, yL) - 1 + ELSE + i := xL; + REPEAT DEC(i); d := x[i] - y[i] UNTIL (i = 0) OR (d # 0) + END; + IF d > 0 THEN + int := New(i + 1); Subtract(x, y, int, xL, yL, intL); SetLength(int, intL, xNeg) + ELSIF d < 0 THEN + int := New(i + 1); Subtract(y, x, int, yL, xL, intL); SetLength(int, intL, yNeg # subtract) + ELSE int := zero + END + END; + RETURN int + END AddOp; + + PROCEDURE Sum* (x, y: Integer): Integer; + BEGIN + RETURN AddOp(x, y, FALSE) + END Sum; + + PROCEDURE Difference*(x, y: Integer): Integer; + BEGIN + RETURN AddOp(x, y, TRUE) + END Difference; + + PROCEDURE Product* (x, y: Integer): Integer; + VAR xL, yL, intL: Index; neg, xNeg, yNeg: BOOLEAN; int: Integer; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); neg := xNeg # yNeg; + IF xL > yL THEN int := x; x := y; y := int; intL := xL; xL := yL; yL := intL; xNeg := yNeg END; + (* x.nofDigits <= y.nofDigits - yNeg no more valid! *) + IF xL = 0 THEN int := zero + ELSIF (xL = 1) & (x[0] = 1) THEN + IF xNeg THEN + int := New(yL); SetLength(int, yL, neg); + REPEAT DEC(yL); int[yL] := y[yL] UNTIL yL = 0 + ELSE int := y + END + ELSE + int := New(xL + yL); Multiply(x, y, int, xL, yL, intL); SetLength(int, intL, neg) + END; + RETURN int + END Product; + + PROCEDURE Quotient* (x, y: Integer): Integer; + VAR xL, yL, intL, remL: Index; xNeg, yNeg, qNeg, rNeg: BOOLEAN; + int: Integer; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); + ASSERT(yL # 0, 20); + IF xL < yL THEN int := zero + ELSIF (yL = 1) & (y[0] = 1) THEN + IF yNeg THEN + int := New(xL); SetLength(int, xL, ~xNeg); + REPEAT DEC(xL); int[xL] := x[xL] UNTIL xL = 0 + ELSE int := x + END + ELSE + int := New(xL - yL + 2); + GetQuoRem(x, y, xL, yL, xNeg, yNeg, int, NIL, intL, remL, qNeg, rNeg, TRUE, FALSE); + SetLength(int, intL, qNeg) + END; + RETURN int + END Quotient; + + PROCEDURE Remainder* (x, y: Integer): Integer; + VAR xL, yL, intL, quoL: Index; xNeg, yNeg, qNeg, rNeg: BOOLEAN; + int: Integer; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); + ASSERT(yL # 0, 20); + IF xL < yL THEN int := x + ELSIF (yL = 1) & (y[0] = 1) THEN int := zero + ELSE + int := New(yL); + GetQuoRem(x, y, xL, yL, xNeg, yNeg, NIL, int, quoL, intL, qNeg, rNeg, FALSE, TRUE); + SetLength(int, intL, rNeg) + END; + RETURN int + END Remainder; + + PROCEDURE QuoRem* (x, y: Integer; OUT quo, rem: Integer); + VAR xL, yL, quoL, remL: Index; xNeg, yNeg, qNeg, rNeg: BOOLEAN; + BEGIN + GetLength(x, xL, xNeg); GetLength(y, yL, yNeg); + ASSERT(yL # 0, 20); + IF xL < yL THEN quo := zero; rem := x + ELSIF (yL = 1) & (y[0] = 1) THEN + rem := zero; + IF yNeg THEN + quo := New(xL); SetLength(quo, xL, ~xNeg); + REPEAT DEC(xL); quo[xL] := x[xL] UNTIL xL = 0 + ELSE quo := x + END + ELSE + quo := New(xL - yL + 2); rem := New(yL); + GetQuoRem(x, y, xL, yL, xNeg, yNeg, quo, rem, quoL, remL, qNeg, rNeg, TRUE, TRUE); + SetLength(quo, quoL, qNeg); SetLength(rem, remL, rNeg) + END + END QuoRem; + + PROCEDURE GCD* (x, y: Integer): Integer; + VAR xL, yL, i: Index; h: Digit; negative: BOOLEAN; xBuf, yBuf, int: Integer; + BEGIN + GetLength(x, xL, negative); GetLength(y, yL, negative); + IF xL = 0 THEN int := y + ELSIF yL = 0 THEN int := x + ELSE + IF xL >= yL THEN xBuf := CopyOf(x, xL + 1); yBuf := CopyOf(y, yL + 1) + ELSE xBuf := CopyOf(y, yL + 1); yBuf := CopyOf(x, xL + 1); i := xL; xL := yL; yL := i + END; + WHILE yL # 0 DO + DecomposeQuoRem(xBuf, yBuf, xL, yL); + xL := yL; + WHILE (xL # 0) & (xBuf[xL - 1] = 0) DO DEC(xL) END; + i := yL; + WHILE i # 0 DO DEC(i); h := xBuf[i]; xBuf[i] := yBuf[i]; yBuf[i] := h END; + i := xL; xL := yL; yL := i + END; + int := New(xL); SetLength(int, xL, FALSE); + WHILE xL # 0 DO DEC(xL); int[xL] := xBuf[xL] END + END; + RETURN int + END GCD; + + PROCEDURE Power* (x: Integer; exp: INTEGER): Integer; + VAR xL, intL: Index; negative: BOOLEAN; int: Integer; + BEGIN + ASSERT(exp >= 0, 20); + GetLength(x, xL, negative); + IF xL = 0 THEN int := zero + ELSIF (xL = 1) & (x[0] = 1) THEN + IF negative & ~ODD(exp) THEN + int := New(xL); SetLength(int, xL, FALSE); + REPEAT DEC(xL); int[xL] := x[xL] UNTIL xL = 0 + ELSE int := x + END + ELSIF exp = 0 THEN int := one + ELSIF exp = 1 THEN int := x + ELSE + int := New(SHORT((xL - 1) * exp + ENTIER(Math.Ln(x[xL - 1] + 1) * exp / Math.Ln(B)) + 1)); + BinPower(x, exp, int, xL, intL); SetLength(int, intL, negative & ODD(exp)) + END; + RETURN int + END Power; + + (* Read from and Write to String and File *) + + PROCEDURE ConvertFromString* (IN s: ARRAY OF CHAR; OUT x: Integer); + VAR i, j, k: INTEGER; dig, b: Digit; ch: CHAR; negative: BOOLEAN; new: Integer; + BEGIN + i := 0; ch := s[0]; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; + negative := ch = "-"; + IF negative THEN INC(i); ch := s[i] END; + IF ch = "+" THEN INC(i); ch := s[i] END; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; + ASSERT((ch >= "0") & (ch <= "9"), 20); + WHILE ch = "0" DO INC(i); ch := s[i] END; + IF (ch > "0") & (ch <= "9") THEN + j := i; + REPEAT INC(j); ch := s[j] UNTIL (ch < "0") OR (ch > "9"); + k := (j - i - 1) DIV DecPerDig + 2; + new := New(k); SetLength(new, k - 1, negative); + k := (j - i) MOD DecPerDig; + IF k # 0 THEN + b := 1; DEC(k); + WHILE k # 0 DO DEC(k); b := SHORT(b * 10) END + ELSE b := B DIV 10 + END; + REPEAT + dig := 0; + WHILE b # 0 DO + dig := SHORT(dig + b * (ORD(s[i]) - ORD("0"))); b := SHORT(b DIV 10); + INC(i) + END; + new[(j - i) DIV DecPerDig] := dig; b := B DIV 10 + UNTIL i = j; + x := new + ELSE x := zero + END + END ConvertFromString; + + PROCEDURE ConvertToString* (x: Integer; OUT s: ARRAY OF CHAR); + VAR j: Index; i: INTEGER; d, b: Digit; negative: BOOLEAN; + BEGIN + GetLength(x, j, negative); + IF negative THEN s[0] := "-"; i := 1 ELSE i := 0 END; + IF j # 0 THEN + DEC(j); d := x[j]; b := B DIV 10; + WHILE d DIV b = 0 DO b := SHORT(b DIV 10) END; + REPEAT + s[i] := CHR(d DIV b + ORD("0")); INC(i); d := SHORT(d MOD b); b := SHORT(b DIV 10) + UNTIL b = 0; + WHILE j # 0 DO + DEC(j); d := x[j]; b := B DIV 10; + REPEAT + s[i] := CHR(d DIV b + ORD("0")); INC(i); d := SHORT(d MOD b); b := SHORT(b DIV 10) + UNTIL b = 0 + END + ELSE s[i] := "0"; INC(i) + END; + s[i] := 0X + END ConvertToString; + + PROCEDURE Internalize* (r: Files.Reader; OUT x: Integer); + VAR len: Index; n, version: INTEGER; negative: BOOLEAN; + new: Integer; buf: ARRAY 4 OF BYTE; + BEGIN + r.ReadByte(buf[0]); version := buf[0]; + ASSERT((version = 0) OR (version >= 128), 20); + IF version = 0 THEN + r.ReadBytes(buf, 0, 4); + len := (((buf[0] MOD 128) * 256 + buf[1] MOD 256) * 256 + + buf[2] MOD 256) * 256 + buf[3] MOD 256; + new := New(len); SetLength(new, len, buf[0] < 0); + WHILE len # 0 DO + DEC(len); + r.ReadBytes(buf, 0, 2); new[len] := SHORT((buf[0] MOD 256) * 256 + buf[1] MOD 256) + END; + x := new + ELSE (* version >= 128 *) + r.ReadByte(buf[1]); n := (buf[0] MOD 256) * 256 + buf[1] MOD 256 - 32768; + r.ReadBytes(buf, 0, 2); DEC(n); + len := (buf[0] MOD 256) * 256 + buf[1] MOD 256; negative := len < 0; len := ABS(len); + new := New(len); SetLength(new, len, negative); + WHILE n # len DO DEC(n); r.ReadBytes(buf, 0, 2) END; + WHILE len # 0 DO + DEC(len); + r.ReadBytes(buf, 0, 2); new[len] := SHORT((buf[0] MOD 256) * 256 + buf[1] MOD 256) + END; + x := new + END + END Internalize; + + PROCEDURE Externalize* (w: Files.Writer; x: Integer); + VAR len, l: Index; d: Digit; i: INTEGER; negative: BOOLEAN; buf: ARRAY 4 OF BYTE; + + PROCEDURE Byte(x: INTEGER): BYTE; + BEGIN + ASSERT((x >= MIN(BYTE)) & (x <= MAX(BYTE) - MIN(BYTE)), 20); + IF x > MAX(BYTE) THEN RETURN SHORT(SHORT(x - 256)) ELSE RETURN SHORT(SHORT(x)) END + END Byte; + + BEGIN + GetLength(x, len, negative); l := len; i := 4; + REPEAT DEC(i); buf[i] := Byte(l MOD 256); l := l DIV 256 UNTIL i = 0; + IF negative THEN buf[0] := Byte(128 + buf[0] MOD 256) END; + w.WriteByte(0); w.WriteBytes(buf, 0, 4); + WHILE len # 0 DO + DEC(len); + d := x[len]; buf[0] := Byte(d DIV 256); buf[1] := Byte(d MOD 256); w.WriteBytes(buf, 0, 2) + END + END Externalize; + +BEGIN + ASSERT(B <= BinBase, 20); + zero := New(0); SetLength(zero, 0, FALSE); + one := New(1); one[0] := 1; SetLength(one, 1, FALSE); + two := New(1); two[0] := 2; SetLength(two, 1, FALSE); + NEW(buf6, 6) +END Integers. diff --git a/Trurl-based/System/Mod/Log.txt b/Trurl-based/System/Mod/Log.txt new file mode 100644 index 0000000..ea32ffa --- /dev/null +++ b/Trurl-based/System/Mod/Log.txt @@ -0,0 +1,144 @@ +MODULE Log; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Log.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel; + + TYPE + Hook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + VAR + synch*: BOOLEAN; (* ~synch => output only on FlushBuf *) + force*: BOOLEAN; (* force => every call causes a Views.Restore *) + + hook: Hook; + + PROCEDURE (log: Hook) Guard* (o: ANYPTR): BOOLEAN, NEW, ABSTRACT; + + PROCEDURE (log: Hook) ClearBuf*, NEW, ABSTRACT; + PROCEDURE (log: Hook) FlushBuf*, NEW, ABSTRACT; + + PROCEDURE (log: Hook) Beep*, NEW, ABSTRACT; + PROCEDURE (log: Hook) Char* (ch: CHAR), NEW, ABSTRACT; + PROCEDURE (log: Hook) Int* (n: INTEGER), NEW, ABSTRACT; + PROCEDURE (log: Hook) Real* (x: REAL), NEW, ABSTRACT; + PROCEDURE (log: Hook) String* (IN str: ARRAY OF CHAR), NEW, ABSTRACT; + PROCEDURE (log: Hook) Bool* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (log: Hook) Set* (x: SET), NEW, ABSTRACT; + PROCEDURE (log: Hook) IntForm* (x: INTEGER; base, minWidth: INTEGER; fillCh: CHAR; + showBase: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (log: Hook) RealForm* (x: REAL; precision, minW, expW: INTEGER; + fillCh: CHAR), NEW, ABSTRACT; + PROCEDURE (log: Hook) Tab*, NEW, ABSTRACT; + PROCEDURE (log: Hook) Ln*, NEW, ABSTRACT; + PROCEDURE (log: Hook) Para*, NEW, ABSTRACT; + PROCEDURE (log: Hook) View* (v: ANYPTR), NEW, ABSTRACT; + PROCEDURE (log: Hook) ViewForm* (v: ANYPTR; w, h: INTEGER), NEW, ABSTRACT; + PROCEDURE (log: Hook) ParamMsg* (IN s, p0, p1, p2: ARRAY OF CHAR), NEW, ABSTRACT; + + + PROCEDURE SetHook*(h: Hook); + BEGIN + hook := h + END SetHook; + + PROCEDURE ClearBuf*; + BEGIN + IF hook # NIL THEN hook.ClearBuf END + END ClearBuf; + + PROCEDURE FlushBuf*; + BEGIN + IF hook # NIL THEN hook.FlushBuf END + END FlushBuf; + + PROCEDURE Guard* (o: ANYPTR): BOOLEAN; + BEGIN + RETURN (hook # NIL) & hook.Guard(o) + END Guard; + + + PROCEDURE Beep*; + BEGIN + IF hook # NIL THEN hook.Beep() END + END Beep; + + PROCEDURE Char* (ch: CHAR); + BEGIN + IF hook # NIL THEN hook.Char(ch) END + END Char; + + PROCEDURE Int* (n: INTEGER); + BEGIN + IF hook # NIL THEN hook.Int(n) END + END Int; + + PROCEDURE Real* (x: REAL); + BEGIN + IF hook # NIL THEN hook.Real(x) END + END Real; + + PROCEDURE String* (str: ARRAY OF CHAR); + BEGIN + IF hook # NIL THEN hook.String(str) END + END String; + + PROCEDURE Bool* (x: BOOLEAN); + BEGIN + IF hook # NIL THEN hook.Bool(x) END + END Bool; + + PROCEDURE Set* (x: SET); + BEGIN + IF hook # NIL THEN hook.Set(x) END + END Set; + + PROCEDURE IntForm* (x: INTEGER; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN); + BEGIN + IF hook # NIL THEN hook.IntForm(x, base, minWidth, fillCh, showBase) END + END IntForm; + + PROCEDURE RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR); + BEGIN + IF hook # NIL THEN hook.RealForm(x, precision, minW, expW, fillCh) END + END RealForm; + + PROCEDURE Tab*; + BEGIN + IF hook # NIL THEN hook.Tab END + END Tab; + + PROCEDURE Ln*; + BEGIN + IF hook # NIL THEN hook.Ln END + END Ln; + + PROCEDURE Para*; + BEGIN + IF hook # NIL THEN hook.Para END + END Para; + + PROCEDURE View* (v: ANYPTR); + BEGIN + IF hook # NIL THEN hook.View(v) END + END View; + + PROCEDURE ViewForm* (v: ANYPTR; w, h: INTEGER); + BEGIN + IF hook # NIL THEN hook.ViewForm(v, w, h) END + END ViewForm; + + PROCEDURE ParamMsg* (s, p0, p1, p2: ARRAY OF CHAR); + BEGIN + IF hook # NIL THEN hook.ParamMsg(s, p0, p1, p2) END + END ParamMsg; + + PROCEDURE Msg* (s: ARRAY OF CHAR); + BEGIN + ParamMsg(s, "", "", "") + END Msg; + +BEGIN + synch := TRUE; force := FALSE +END Log. diff --git a/Trurl-based/System/Mod/Math.txt b/Trurl-based/System/Mod/Math.txt new file mode 100644 index 0000000..936cf15 --- /dev/null +++ b/Trurl-based/System/Mod/Math.txt @@ -0,0 +1,532 @@ +MODULE Math; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Math.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM; + + VAR eps, e: REAL; + + + (* code procedures for 80387 math coprocessor *) + + PROCEDURE [code] FLD (x: REAL); + PROCEDURE [code] TOP (): REAL; + PROCEDURE [code] FSW (): INTEGER 0DFH, 0E0H; + PROCEDURE [code] FSWs (): SET 0DFH, 0E0H; + PROCEDURE [code] ST0 (): REAL 0D9H, 0C0H; + PROCEDURE [code] ST1 (): REAL 0D9H, 0C1H; + + PROCEDURE [code] FXCH 0D9H, 0C9H; + PROCEDURE [code] FLDst0 0D9H, 0C0H; (* doublicate st[0] *) + PROCEDURE [code] FSTPst0 0DDH, 0D8H; (* remove st[0] *) + PROCEDURE [code] FSTPst1 0DDH, 0D9H; (* remove st[1] *) + PROCEDURE [code] FSTPDe 0DBH, 05DH, 0F4H; (* FSTPD -12[FP] *) (* COMPILER DEPENDENT *) + PROCEDURE [code] WAIT 09BH; + PROCEDURE [code] FNOP 0D9H, 0D0H; + + PROCEDURE [code] FLD0 0D9H, 0EEH; + PROCEDURE [code] FLD1 0D9H, 0E8H; + PROCEDURE [code] FLDPI 0D9H, 0EBH; + PROCEDURE [code] FLDLN2 0D9H, 0EDH; + PROCEDURE [code] FLDLG2 0D9H, 0ECH; + PROCEDURE [code] FLDL2E 0D9H, 0EAH; + + PROCEDURE [code] FADD 0DEH, 0C1H; + PROCEDURE [code] FADDst0 0D8H, 0C0H; + PROCEDURE [code] FSUB 0DEH, 0E9H; + PROCEDURE [code] FSUBn 0DCH, 0E9H; (* no pop *) + PROCEDURE [code] FSUBR 0DEH, 0E1H; + PROCEDURE [code] FSUBst1 0D8H, 0E1H; + PROCEDURE [code] FMUL 0DEH, 0C9H; + PROCEDURE [code] FMULst0 0D8H, 0C8H; + PROCEDURE [code] FMULst1st0 0DCH, 0C9H; + PROCEDURE [code] FDIV 0DEH, 0F9H; + PROCEDURE [code] FDIVR 0DEH, 0F1H; + PROCEDURE [code] FDIVRst1 0D8H, 0F9H; + PROCEDURE [code] FCHS 0D9H, 0E0H; + + PROCEDURE [code] FCOM 0D8H, 0D1H; + PROCEDURE [code] FSWax 0DFH, 0E0H; + PROCEDURE [code] SAHF 09EH; + PROCEDURE [code] JBE4 076H, 004H; + PROCEDURE [code] JAE4 073H, 004H; + + PROCEDURE [code] FRNDINT 0D9H, 0FCH; + PROCEDURE [code] FSCALE 0D9H, 0FDH; (* st[0] * 2^FLOOR(st[1]) *) + PROCEDURE [code] FXTRACT 0D9H, 0F4H; (* exp -> st[1]; mant -> st[0] *) + PROCEDURE [code] FXAM 0D9H, 0E5H; + + PROCEDURE [code] FSQRT 0D9H, 0FAH; (* st[0] >= 0 *) + PROCEDURE [code] FSIN 0D9H, 0FEH; (* |st[0]| < 2^63 *) + PROCEDURE [code] FCOS 0D9H, 0FFH; (* |st[0]| < 2^63 *) + PROCEDURE [code] FTAN 0D9H, 0F2H; (* |st[0]| < 2^63 *) + PROCEDURE [code] FATAN 0D9H, 0F3H; (* atan2(st[1], st[0]) *) + PROCEDURE [code] FYL2X 0D9H, 0F1H; (* st[1] * log2(st[0]), st[0] > 0 *) + PROCEDURE [code] FYL2XP1 0D9H, 0F9H; (* st[1] * log2(1 + st[0]), |st[0]| < 1-sqrt(2)/2 *) + PROCEDURE [code] F2XM1 0D9H, 0F0H; (* 2^st[0] - 1, |st[0]| <= 1 *) + + + PROCEDURE IsNan (x: REAL): BOOLEAN; + BEGIN + FLD(x); FXAM; FSTPst0; WAIT; RETURN FSWs() * {8, 10} = {8} + END IsNan; + + + (* sin, cos, tan argument reduction *) + + PROCEDURE Reduce; + BEGIN + FXAM; WAIT; + IF ~(8 IN FSWs()) & (ABS(ST0()) > 1.0E18) THEN + (* to be completed *) + FSTPst0; FLD0 + END; + END Reduce; + + + (** REAL precision **) + + PROCEDURE Pi* (): REAL; + BEGIN + FLDPI; RETURN TOP() + END Pi; + + PROCEDURE Eps* (): REAL; + BEGIN + RETURN eps + END Eps; + + + PROCEDURE Sqrt* (x: REAL): REAL; + BEGIN + (* 20, argument of Sqrt must not be negative *) + FLD(x); FSQRT; WAIT; RETURN TOP() + END Sqrt; + + + PROCEDURE Exp* (x: REAL): REAL; + BEGIN + (* 2 ^ (x * 1/ln(2)) *) + FLD(x); FLDL2E; FMUL; + IF ABS(ST0()) = INF THEN FLD1 + ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD + END; + FSCALE; FSTPst1; RETURN TOP() + END Exp; + + PROCEDURE Ln* (x: REAL): REAL; + BEGIN + (* 20, argument of Ln must not be negative *) + (* ln(2) * ld(x) *) + FLDLN2; FLD(x); FYL2X; WAIT; RETURN TOP() + END Ln; + + PROCEDURE Log* (x: REAL): REAL; + BEGIN + (* 20, argument of Log must not be negative *) + (* log(2) * ld(x) *) + FLDLG2; FLD(x); FYL2X; WAIT; RETURN TOP() + END Log; + + PROCEDURE Power* (x, y: REAL): REAL; + BEGIN + ASSERT(x >= 0, 20); + ASSERT((x # 0.0) OR (y # 0.0), 21); + ASSERT((x # INF) OR (y # 0.0), 22); + ASSERT((x # 1.0) OR (ABS(y) # INF), 23); + (* 2 ^ (y * ld(x)) *) + FLD(y); FLD(x); FYL2X; + IF ABS(ST0()) = INF THEN FLD1 + ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD + END; + FSCALE; FSTPst1; WAIT; RETURN TOP() + END Power; + + PROCEDURE IntPower* (x: REAL; n: INTEGER): REAL; + BEGIN + FLD1; FLD(x); + IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END; + IF n <= 0 THEN FDIVRst1; (* 1 / x *) n := -n END; + WHILE n > 0 DO + IF ODD(n) THEN FMULst1st0; (* y := y * x *) DEC(n) + ELSE FMULst0; (* x := x * x *) n := n DIV 2 + END + END; + FSTPst0; RETURN TOP() + END IntPower; + + + PROCEDURE Sin* (x: REAL): REAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FSIN; WAIT; RETURN TOP() + END Sin; + + PROCEDURE Cos* (x: REAL): REAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FCOS; WAIT; RETURN TOP() + END Cos; + + PROCEDURE Tan* (x: REAL): REAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FTAN; FSTPst0; WAIT; RETURN TOP() + END Tan; + + PROCEDURE ArcSin* (x: REAL): REAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* atan2(x, sqrt(1 - x*x)) *) + FLD(x); FLDst0; FMULst0; FLD1; FSUBR; FSQRT; FNOP; FATAN; WAIT; RETURN TOP() + END ArcSin; + + PROCEDURE ArcCos* (x: REAL): REAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* atan2(sqrt(1 - x*x), x) *) + FLD(x); FMULst0; FLD1; FSUBR; FSQRT; FLD(x); FATAN; WAIT; RETURN TOP() + END ArcCos; + + PROCEDURE ArcTan* (x: REAL): REAL; + BEGIN + (* atan2(x, 1) *) + FLD(x); FLD1; FATAN; RETURN TOP() + END ArcTan; + + PROCEDURE ArcTan2* (y, x: REAL): REAL; + BEGIN + ASSERT((y # 0) OR (x # 0), 20); + ASSERT((ABS(y) # INF) OR (ABS(x) # INF), 21); + FLD(y); FLD(x); FATAN; WAIT; RETURN TOP() + END ArcTan2; + + + PROCEDURE Sinh* (x: REAL): REAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* abs(x) * 1/ln(2) *) + FLD(ABS(x)); FLDL2E; FMUL; + IF ST0() < 0.5 THEN + (* (2^z - 1) + (2^z - 1) / ((2^z - 1) + 1) *) + F2XM1; FLDst0; FLDst0; FLD1; FADD; FDIV; FADD + ELSIF ST0() # INF THEN + (* 2^z - 1 / 2^z *) + FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; + FSTPst1; FLDst0; FLD1; FDIVR; FSUB + END; + IF x < 0 THEN FCHS END; + RETURN TOP() * 0.5 + END Sinh; + + PROCEDURE Cosh* (x: REAL): REAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* 2^(abs(x) * 1/ln(2)) *) + FLD(ABS(x)); + IF ST0() # INF THEN + FLDL2E; FMUL; FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; + FSTPst1; + (* z + 1/z *) + FLDst0; FLD1; FDIVR; FADD + END; + RETURN TOP() * 0.5 + END Cosh; + + PROCEDURE Tanh* (x: REAL): REAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* abs(x) * 1/ln(2) * 2 *) + FLD(ABS(x)); FLDL2E; FMUL; FADDst0; + IF ST0() < 0.5 THEN + (* (2^z - 1) / (2^z + 1) *) + F2XM1; FLDst0; FLD(2); FADD; FDIV + ELSIF ST0() < 65 THEN + (* 1 - 2 / (2^z + 1) *) + FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; + FSTPst1; FLD1; FADD; FLD(2); FDIVR; FLD1; FSUBR + ELSE + FSTPst0; FLD1 + END; + IF x < 0 THEN FCHS END; + RETURN TOP() + END Tanh; + + PROCEDURE ArcSinh* (x: REAL): REAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* x*x *) + FLDLN2; FLD(ABS(x)); FLDst0; FMULst0; + IF ST0() < 0.067 THEN + (* ln(2) * ld(1 + x*x / (sqrt(x*x + 1) + 1) + x) *) + FLDst0; FLD1; FADD; FSQRT; FLD1; FADD; FDIV; FADD; FYL2XP1 + ELSE + (* ln(2) * ld(x + sqrt(x*x + 1)) *) + FLD1; FADD; FSQRT; FADD; FYL2X + END; + IF x < 0 THEN FCHS END; + RETURN TOP() + END ArcSinh; + + PROCEDURE ArcCosh* (x: REAL): REAL; + BEGIN + (* 20, x >= 1.0 *) + (* IF IsNan(x) THEN RETURN x END; *) + (* ln(2) * ld(x + sqrt(x*x - 1)) *) + FLDLN2; FLD(x); FLDst0; FMULst0; FLD1; FSUB; FSQRT; FADD; FYL2X; WAIT; RETURN TOP() + END ArcCosh; + + PROCEDURE ArcTanh* (x: REAL): REAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* IF IsNan(x) THEN RETURN x END; *) + (* |x| *) + FLDLN2; FLD(ABS(x)); + IF ST0() < 0.12 THEN + (* ln(2) * ld(1 + 2*x / (1 - x)) *) + FLDst0; FLD1; FSUBR; FDIV; FADDst0; FYL2XP1 + ELSE + (* ln(2) * ld((1 + x) / (1 - x)) *) + FLDst0; FLD1; FADD; FXCH; FLD1; FSUBR; FDIV; FNOP; FYL2X + END; + IF x < 0 THEN FCHS END; + WAIT; + RETURN TOP() * 0.5 + END ArcTanh; + + + PROCEDURE Floor* (x: REAL): REAL; + BEGIN + FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB; RETURN TOP() + END Floor; + + PROCEDURE Ceiling* (x: REAL): REAL; + BEGIN + FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD; RETURN TOP() + END Ceiling; + + PROCEDURE Round* (x: REAL): REAL; + BEGIN + FLD(x); + IF ABS(ST0()) = INF THEN RETURN TOP() END; + FLDst0; FRNDINT; FSUBn; FXCH; + IF TOP() = 0.5 THEN FLD1; FADD END; + RETURN TOP() + END Round; + + PROCEDURE Trunc* (x: REAL): REAL; + BEGIN + FLD(x); FLDst0; FRNDINT; + IF ST1() >= 0 THEN + FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB + ELSE + FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD + END; + RETURN TOP() + END Trunc; + + PROCEDURE Frac* (x: REAL): REAL; + BEGIN + (* 20, x # INF & x # -INF *) + FLD(x); FLDst0; FRNDINT; + IF ST1() >= 0 THEN + FCOM; FSWax; SAHF; JBE4; FLD1; FSUB + ELSE + FCOM; FSWax; SAHF; JAE4; FLD1; FADD + END; + FSUB; WAIT; RETURN TOP() + END Frac; + + + PROCEDURE Sign* (x: REAL): REAL; + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 0, 2: FSTPst0; RETURN 0.0 + | 1, 4, 5: FSTPst0; RETURN 1.0 + | 3, 6, 7: FSTPst0; RETURN -1.0 + END + END Sign; + + PROCEDURE Mantissa* (x: REAL): REAL; + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 4, 6: FXTRACT; FSTPst1; RETURN TOP() + | 0, 2: FSTPst0; RETURN 0.0 (* zero *) + | 5: FSTPst0; RETURN 1.0 (* inf *) + | 7: FSTPst0; RETURN -1.0 (* -inf *) + | 1: FSTPst0; RETURN 1.5 (* nan *) + | 3: FSTPst0; RETURN -1.5 (* -nan *) + END + END Mantissa; + + PROCEDURE Exponent* (x: REAL): INTEGER; (* COMPILER DEPENDENT *) + VAR e: INTEGER; (* e is set by FSTPDe! *) + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 4, 6: FXTRACT; FSTPst0; FSTPDe; WAIT; RETURN e + | 0, 2: FSTPst0; RETURN 0 (* zero *) + | 1, 3, 5, 7: FSTPst0; RETURN MAX(INTEGER) (* inf or nan*) + END + END Exponent; + + PROCEDURE Real* (m: REAL; e: INTEGER): REAL; + VAR s: SET; + BEGIN + IF (m = 0) THEN RETURN 0.0 END; + ASSERT(~IsNan(m) & (1 <= ABS(m)) & (ABS(m) < 2), 20); + IF e = MAX(INTEGER) THEN + SYSTEM.GET(SYSTEM.ADR(m) + 4, s); + SYSTEM.PUT(SYSTEM.ADR(m) + 4, s + {20..30}); + RETURN m + ELSE + FLD(e); FLD(m); FSCALE; FSTPst1; RETURN TOP() + END + END Real; + +BEGIN + eps := 1.0E+0; e := 2.0E+0; + WHILE e > 1.0E+0 DO eps := eps/2.0E+0; e := 1.0E+0 + eps END; eps := 2.0E+0 * eps; +END Math. + + + + PROCEDURE Log* (x: REAL): REAL; + BEGIN + RETURN Ln(x)/ln10 + END Log; + + PROCEDURE Power* (x, y: REAL): REAL; + BEGIN + RETURN Exp(y * Ln(x)) + END Power; + + PROCEDURE IntPower* (x: REAL; n: LONGINT): REAL; + VAR y: REAL; + BEGIN y := 1.0E+0; + IF n < 0 THEN x := 1.0E+0/x; n := -n END; + WHILE n > 0 DO + IF ODD(n) THEN y := y*x; DEC(n) + ELSE x := x * x; n := n DIV 2 + END + END; + RETURN y + END IntPower; + + PROCEDURE Tan* (x: REAL): REAL; + BEGIN + RETURN Sin(x)/Cos(x) + END Tan; + + PROCEDURE ArcSin* (x: REAL): REAL; + BEGIN + RETURN 2.0E+0 * ArcTan(x/(1.0E+0 + Sqrt(1.0E+0 - x*x))) + END ArcSin; + + PROCEDURE ArcCos* (x: REAL): REAL; + BEGIN (* pi/2 - arcsin(x) *) + RETURN Pi()/2.0E+0 - 2.0E+0 * ArcTan(x/(1.0E+0 + Sqrt(1.0E+0 - x*x))) +(* + IF x = -1 THEN RETURN Pi() + ELSE RETURN 2 * ArcTan(Sqrt((1 - x) / (1 + x))) + END +*) END ArcCos; + + PROCEDURE ArcTan2* (y, x: REAL): REAL; + BEGIN + IF x = 0.0 THEN + RETURN Sign(y) * Pi() / 2.0 + ELSIF y = 0.0 THEN + RETURN (1.0 - Sign(x)) * Pi() / 2.0 + ELSE + RETURN ArcTan(y/x) + (1.0 - Sign(x)) * Sign(y) * Pi() / 2.0 + END + END ArcTan2; + + PROCEDURE Sinh* (x: REAL): REAL; + BEGIN + IF ABS(x) < -lneps THEN RETURN (Exp(x)-Exp(-x))/2.0E+0 + ELSE RETURN Sign(x)*Exp(ABS(x))/2.0E+0 + END + END Sinh; + + PROCEDURE Cosh* (x: REAL): REAL; + BEGIN + IF ABS(x) < -lneps THEN RETURN (Exp(x)+Exp(-x))/2.0E+0 + ELSE RETURN Exp(ABS(x))/2.0E+0 + END + END Cosh; + + PROCEDURE Tanh* (x: REAL): REAL; + VAR e1, e2: REAL; + BEGIN + IF ABS(x) < -lneps THEN + e1 := Exp(x); e2 := 1.0E+0/e1; + RETURN (e1-e2)/(e1+e2) + ELSE + RETURN Sign(x) + END + END Tanh; + + PROCEDURE ArcSinh* (x: REAL): REAL; + BEGIN + IF x >= 0.0E+0 THEN RETURN Ln(x + Sqrt(x*x + 1.0E+0)) + ELSE RETURN - Ln(-x + Sqrt(x*x + 1.0E+0)) + END + END ArcSinh; + + PROCEDURE ArcCosh* (x: REAL): REAL; + BEGIN + RETURN Ln(x + Sqrt(x*x - 1.0E+0)) + END ArcCosh; + + PROCEDURE ArcTanh* (x: REAL): REAL; + BEGIN + RETURN Ln((1.0E+0 + x)/(1.0E+0 - x))/2.0E+0 + (* Variants: + (Ln(1+x)-Ln(1-x))/2.0E+0 + -Ln((1-x)/Sqrt(1-x*x)) + arcsinh(x/sqrt(1-x*x)) + *) + END ArcTanh; + + PROCEDURE Floor* (x: REAL): REAL; + BEGIN + IF ABS(x) >= 1.0E16 THEN RETURN x + ELSE RETURN ENTIER(x) + END + END Floor; + + PROCEDURE Ceiling* (x: REAL): REAL; + BEGIN + IF ABS(x) >= 1.0E16 THEN RETURN x + ELSE RETURN -ENTIER(-x) + END + END Ceiling; + + PROCEDURE Round* (x: REAL): REAL; + BEGIN + IF ABS(x) >= 1.0E16 THEN RETURN x + ELSE RETURN ENTIER(x + 0.5) + END + END Round; + + PROCEDURE Trunc* (x: REAL): REAL; + BEGIN + IF ABS(x) >= 1.0E16 THEN RETURN x + ELSIF x >= 0 THEN RETURN ENTIER(x) + ELSE RETURN -ENTIER(-x) + END + END Trunc; + + PROCEDURE Frac* (x: REAL): REAL; + BEGIN + IF ABS(x) >= 1.0E16 THEN RETURN 0.0 + ELSIF x >= 0 THEN RETURN x - ENTIER(x) + ELSE RETURN x + ENTIER(-x) + END + END Frac; + diff --git a/Trurl-based/System/Mod/Mechanisms.txt b/Trurl-based/System/Mod/Mechanisms.txt new file mode 100644 index 0000000..078c8ff --- /dev/null +++ b/Trurl-based/System/Mod/Mechanisms.txt @@ -0,0 +1,129 @@ +MODULE Mechanisms; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Mechanisms.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, Views; + + CONST + (** FocusBorderCursor/SelBorderCursor result **) + inside* = -1; outside* = -2; (** plus defined Ports cursors **) + + (** TrackToResize op **) + cancelResize* = 0; resize* = 1; + + (** TrackToDrop op **) + cancelDrop* = 0; copy* = 1; move* = 2; link* = 3; + + (** TrackToPick op **) + cancelPick* = 0; pick* = 1; pickForeign* = 2; + + TYPE + Hook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + VAR hook: Hook; + + PROCEDURE SetHook*(h: Hook); + BEGIN + hook := h + END SetHook; + + PROCEDURE (hook: Hook) MarkFocusBorder* (host: Views.Frame; + focus: Views.View; l, t, r, b: INTEGER; + show: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (hook: Hook) MarkSingletonBorder* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + show: BOOLEAN), NEW, ABSTRACT; + + PROCEDURE (hook: Hook) FocusBorderCursor* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + x, y: INTEGER): INTEGER, NEW, ABSTRACT; + PROCEDURE (hook: Hook) SelBorderCursor* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + x, y: INTEGER): INTEGER, NEW, ABSTRACT; + + PROCEDURE (hook: Hook) TrackToResize* (host: Views.Frame; view: Views.View; + minW, maxW, minH, maxH: INTEGER; + VAR l, t, r, b: INTEGER; VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET), NEW, ABSTRACT; + PROCEDURE (hook: Hook) TrackToDrop* (source: Views.Frame; view: Views.View; + isSingle: BOOLEAN; w, h, rx, ry: INTEGER; + VAR dest: Views.Frame; VAR destX, destY: INTEGER; + VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET), NEW, ABSTRACT; + PROCEDURE (hook: Hook) TrackToPick* (source: Views.Frame; + VAR dest: Views.Frame; VAR destX, destY: INTEGER; + VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET), NEW, ABSTRACT; + + PROCEDURE (hook: Hook) PopUpAndSelect* (f: Views.Frame; + n, this: INTEGER; + s: ARRAY OF ARRAY OF CHAR; + enabled, checked: ARRAY OF BOOLEAN; + VAR i: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET), NEW, ABSTRACT; + + PROCEDURE MarkFocusBorder* (host: Views.Frame; + focus: Views.View; l, t, r, b: INTEGER; + show: BOOLEAN); + BEGIN + hook.MarkFocusBorder(host, focus, l, t, r, b, show) + END MarkFocusBorder; + + PROCEDURE MarkSingletonBorder* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + show: BOOLEAN); + BEGIN + hook.MarkSingletonBorder(host, view, l, t, r, b, show) + END MarkSingletonBorder; + + PROCEDURE FocusBorderCursor* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + x, y: INTEGER): INTEGER; + BEGIN + RETURN hook.FocusBorderCursor(host, view, l, t, r, b, x, y) + END FocusBorderCursor; + + PROCEDURE SelBorderCursor* (host: Views.Frame; + view: Views.View; l, t, r, b: INTEGER; + x, y: INTEGER): INTEGER; + BEGIN + RETURN hook.SelBorderCursor(host, view, l, t, r, b, x, y) + END SelBorderCursor; + + PROCEDURE TrackToResize* (host: Views.Frame; view: Views.View; + minW, maxW, minH, maxH: INTEGER; + VAR l, t, r, b: INTEGER; VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET); + BEGIN + hook.TrackToResize(host, view, minW, maxW, minH, maxH, l, t, r, b, op, x, y, buttons) + END TrackToResize; + + PROCEDURE TrackToDrop* (source: Views.Frame; view: Views.View; + isSingle: BOOLEAN; w, h, rx, ry: INTEGER; + VAR dest: Views.Frame; VAR destX, destY: INTEGER; + VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET); + BEGIN + hook.TrackToDrop(source, view, isSingle, w, h, rx, ry, dest, destX, destY, op, x, y, buttons) + END TrackToDrop; + + PROCEDURE TrackToPick* (source: Views.Frame; + VAR dest: Views.Frame; VAR destX, destY: INTEGER; + VAR op: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET); + BEGIN + hook.TrackToPick(source, dest, destX, destY, op, x, y, buttons) + END TrackToPick; + + PROCEDURE PopUpAndSelect* (f: Views.Frame; + n, this: INTEGER; + s: ARRAY OF ARRAY OF CHAR; + enabled, checked: ARRAY OF BOOLEAN; + VAR i: INTEGER; + VAR x, y: INTEGER; VAR buttons: SET); + BEGIN + hook.PopUpAndSelect(f, n, this, s, enabled, checked, i, x, y, buttons) + END PopUpAndSelect; + +END Mechanisms. diff --git a/Trurl-based/System/Mod/Meta.txt b/Trurl-based/System/Mod/Meta.txt new file mode 100644 index 0000000..ca36176 --- /dev/null +++ b/Trurl-based/System/Mod/Meta.txt @@ -0,0 +1,1214 @@ +MODULE Meta; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc System/Mod/Meta.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel; + + CONST + (** result codes for object classes, type classes, visibility classes **) + undef* = 0; + + (** object classes **) + typObj* = 2; varObj* = 3; procObj* = 4; fieldObj* = 5; modObj* = 6; parObj* = 7; + + (** type classes **) + boolTyp* = 1; sCharTyp* = 2; charTyp* = 3; + byteTyp* = 4; sIntTyp* = 5; intTyp* = 6; + sRealTyp* = 7; realTyp* = 8; setTyp* = 9; + longTyp* = 10; anyRecTyp* = 11; anyPtrTyp* = 12; + sysPtrTyp = 13; + procTyp* = 16; recTyp* = 17; arrTyp* = 18; ptrTyp* = 19; + + (** record attributes **) + final* = 0; extensible* = 1; limited* = 2; abstract* = 3; + + (** visibility **) + hidden* = 1; readOnly* = 2; private = 3; exported* = 4; + value* = 10; in* = 11; out* = 12; var* = 13; + + (* scanner modes *) + modScan = 1; globScan = 2; recVarScan = 3; recTypeScan = 4; + + TYPE + Name* = ARRAY 256 OF CHAR; + + Value* = ABSTRACT RECORD END; (* to be extended once with a single field of any type *) + + ArrayPtr = POINTER TO Array; + + Item* = RECORD (Value) + obj-: INTEGER; (* typObj, varObj, procObj, fieldObj, modObj, parObj *) + typ-: INTEGER; (* typObj, varObj, fieldObj, parObj: type; else: 0 *) + vis-: INTEGER; (* varObj, procObj, fieldObj, parObj: vis; else: 0 *) + adr-: INTEGER; (* varObj, procObj: adr; fieldObj: offs; parObj: num; else: 0 *) + mod: Kernel.Module; (* static varObj, procObj, modObj: mod; else: NIL *) + desc: Kernel.Type; (* typObj, varObj, fieldObj, parObj: struct; procObj: sig; else: NIL *) + ptr: ArrayPtr; (* # NIL => item valid; dynamic varObj: ptr; else: dummy *) + ext: Kernel.ItemExt (* all method calls forwarded if # NIL *) + END; + + Scanner* = RECORD + this-: Item; + eos-: BOOLEAN; (* end of scan *) + mode: INTEGER; (* modScan, globScan, recVarScan, recTypeScan *) + base: INTEGER; (* recVarScan, recTypeScan: base level index *) + vis: INTEGER; (* recVarScan: record vis *) + adr: INTEGER; (* recVarScan: record adr *) + idx: INTEGER; (* globScan, recVarScan, recTypeScan: object index *) + desc: Kernel.Type; (* recVarScan, recTypeScan: record desc *) + mod: Kernel.Module; (* modScan: next mod; globScan, recVarScan: source mod *) + obj: Kernel.Object (* globScan, recVarScan, recTypeScan: actual object *) + END; + + LookupFilter* = PROCEDURE (IN path: ARRAY OF CHAR; OUT i: Item; OUT done: BOOLEAN); + + FilterHook = POINTER TO RECORD + next: FilterHook; + filter: LookupFilter + END; + + Array = EXTENSIBLE RECORD + w0, w1, w2: INTEGER; (* gc header *) + len: ARRAY 16 OF INTEGER (* dynamic array length table *) + END; + + SStringPtr = POINTER TO ARRAY [1] OF SHORTCHAR; + StringPtr = POINTER TO ARRAY [1] OF CHAR; + + VAR + dummy: ArrayPtr; (* dummy object for item.ptr *) + filterHook: FilterHook; + + + (* preconditions: + ASSERT(i.ptr # NIL, 20); (* invalid item *) + ASSERT(i.typ >= recTyp, 21); (* wrong type *) + ASSERT(i.obj = varObj, 22); (* wrong object class *) + ASSERT((i.mod = NIL) OR (i.mod.refcnt >= 0), 23); (* unloaded object module *) + ASSERT(i.desc.mod.refcnt >= 0, 24); (* unloaded type module *) + ASSERT(d.id DIV 16 MOD 16 = 1, 25); (* value not extended once *) + ASSERT(d.fields.num = 1, 26); (* not a single value field *) + ASSERT(i.vis = exported, 27); (* write protected destination *) + ASSERT(type.desc.base[t.id DIV 16 MOD 16] = t, 28); (* wrong pointer type *) + ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29); (* unexported type *) + ASSERT(type.desc.id DIV 4 MOD 4 < limited, 30); (* limited or abstract type *) + ASSERT(i.ext = NIL, 31); (* unsupported extension *) + *) + + + PROCEDURE DescOf (IN x: ANYREC): Kernel.Type; + BEGIN + RETURN SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(x)) + END DescOf; + + PROCEDURE TypOf (struct: Kernel.Type): INTEGER; + BEGIN + IF SYSTEM.VAL(INTEGER, struct) DIV 256 = 0 THEN + RETURN SYSTEM.VAL(INTEGER, struct) + ELSE + RETURN 16 + struct.id MOD 4 + END + END TypOf; + + PROCEDURE LenOf (IN i: Item): INTEGER; + BEGIN + IF i.desc.size # 0 THEN RETURN i.desc.size + ELSIF i.ptr = dummy THEN RETURN 0 + ELSE RETURN i.ptr.len[i.desc.id DIV 16 MOD 16 - 1] + END + END LenOf; + + PROCEDURE SizeOf (IN i: Item): INTEGER; + VAR el: Item; + BEGIN + CASE i.typ OF + | anyRecTyp: RETURN 0 + | boolTyp, sCharTyp, byteTyp: RETURN 1 + | charTyp, sIntTyp: RETURN 2 + | longTyp, realTyp: RETURN 8 + | recTyp: RETURN i.desc.size + | arrTyp: + el.desc := i.desc.base[0]; el.typ := TypOf(el.desc); el.ptr := i.ptr; + RETURN LenOf(i) * SizeOf(el) + ELSE RETURN 4 + END + END SizeOf; + + PROCEDURE SignatureOf (IN i: Item): Kernel.Signature; + BEGIN + IF i.obj = procObj THEN + RETURN SYSTEM.VAL(Kernel.Signature, i.desc) + ELSE + RETURN SYSTEM.VAL(Kernel.Signature, i.desc.base[0]) + END + END SignatureOf; + + + PROCEDURE GetName (IN path: ARRAY OF CHAR; OUT name: ARRAY OF CHAR; VAR i: INTEGER); + VAR j: INTEGER; ch: CHAR; + BEGIN + j := 0; ch := path[i]; + WHILE (j < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z") + OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO + name[j] := ch; INC(i); INC(j); ch := path[i] + END; + IF (ch = 0X) OR (ch = ".") OR (ch = "[") OR (ch = "^") THEN name[j] := 0X + ELSE name[0] := 0X + END + END GetName; + + PROCEDURE LegalName (IN name: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; ch := name[0]; + WHILE (i < LEN(name) - 1) & ((ch >= "0") & (ch <= "9") OR (CAP(ch) >= "A") & (CAP(ch) <= "Z") + OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_")) DO + INC(i); ch := name[i] + END; + RETURN (i > 0) & (ch = 0X) + END LegalName; + + + (* ---------- Item properties ---------- *) + + PROCEDURE (VAR i: Item) Valid* (): BOOLEAN, NEW; + BEGIN + IF i.ext # NIL THEN RETURN i.ext.Valid() END; + RETURN (i.ptr # NIL) & ((i.mod = NIL) OR (i.mod.refcnt >= 0)) & ((i.typ < recTyp) OR (i.desc.mod.refcnt >= 0)) + END Valid; + + PROCEDURE (VAR i: Item) GetTypeName* (OUT mod, type: Name), NEW; + VAR n: Kernel.Name; + BEGIN + ASSERT(i.ext = NIL, 31); + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ >= recTyp, 21); + ASSERT(i.desc.mod.refcnt >= 0, 24); + mod := i.desc.mod.name$; + Kernel.GetTypeName(i.desc, n); + type := n$ + END GetTypeName; + + PROCEDURE (VAR i: Item) BaseTyp* (): INTEGER, NEW; + BEGIN + IF i.ext # NIL THEN RETURN i.ext.BaseTyp() END; + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21); + RETURN TypOf(i.desc.base[0]) + END BaseTyp; + + PROCEDURE (VAR i: Item) Level* (): INTEGER, NEW; + BEGIN + ASSERT(i.ext = NIL, 31); + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ IN {recTyp, arrTyp}, 21); + RETURN i.desc.id DIV 16 MOD 16 + END Level; + + PROCEDURE (VAR i: Item) Attribute* (): INTEGER, NEW; + BEGIN + ASSERT(i.ext = NIL, 31); + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ = recTyp, 21); + RETURN i.desc.id DIV 4 MOD 4 + END Attribute; + + PROCEDURE (VAR i: Item) Size* (): INTEGER, NEW; + BEGIN + IF i.ext # NIL THEN RETURN i.ext.Size() END; + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ # undef, 21); + RETURN SizeOf(i) + END Size; + + PROCEDURE (VAR arr: Item) Len* (): INTEGER, NEW; + BEGIN + IF arr.ext # NIL THEN RETURN arr.ext.Len() END; + ASSERT(arr.ptr # NIL, 20); + ASSERT(arr.typ = arrTyp, 21); + RETURN LenOf(arr) + END Len; + + (* ---------- Item generation ---------- *) + + PROCEDURE SetUndef (VAR i: Item); + BEGIN + i.typ := undef; i.obj := undef; i.vis := undef; + i.adr := undef; i.mod := NIL; i.desc := NIL; i.ptr := NIL; i.ext := NIL; + END SetUndef; + + PROCEDURE SetItem (VAR i: Item; obj: Kernel.Object; mod: Kernel.Module); + VAR t: Kernel.Type; + BEGIN + i.obj := obj.id MOD 16; + i.vis := obj.id DIV 16 MOD 16; + IF i.obj = procObj THEN + i.typ := undef; i.desc := SYSTEM.VAL(Kernel.Type, obj.struct); + i.adr := mod.procBase + obj.offs; i.mod := mod + ELSE + i.typ := TypOf(obj.struct); i.desc := obj.struct; + IF i.obj = varObj THEN i.adr := mod.varBase + obj.offs; i.mod := mod + ELSIF i.obj = fieldObj THEN i.adr := obj.offs; i.mod := NIL + ELSE i.adr := undef; i.mod := NIL + END + END; + i.ext := NIL + END SetItem; + + PROCEDURE SetMod (VAR i: Item; mod: Kernel.Module); + BEGIN + i.obj := modObj; i.typ := undef; i.vis := undef; + i.adr := undef; i.mod := mod; i.desc := NIL; i.ptr := dummy; i.ext := NIL + END SetMod; + + + PROCEDURE GetItem* (obj: ANYPTR; OUT i: Item); + BEGIN + ASSERT(obj # NIL, 28); + i.obj := varObj; i.typ := recTyp; i.vis := exported; + i.adr := SYSTEM.ADR(obj^); i.ptr := SYSTEM.VAL(ArrayPtr, obj); + i.mod := NIL; i.desc := Kernel.TypeOf(obj); i.ext := NIL + END GetItem; + + PROCEDURE Lookup* (IN name: ARRAY OF CHAR; OUT mod: Item); + VAR m: Kernel.Module; done: BOOLEAN; filter: FilterHook; + BEGIN + done := FALSE; filter := filterHook; + WHILE ~done & (filter # NIL) DO filter.filter(name, mod, done); filter := filter.next END; + IF ~done & LegalName(name) THEN + m := Kernel.ThisMod(name); + IF m # NIL THEN SetMod(mod, m) + ELSE SetUndef(mod) + END + ELSE SetUndef(mod) + END + END Lookup; + + PROCEDURE (VAR in: Item) Lookup* (IN name: ARRAY OF CHAR; VAR i: Item), NEW; + VAR obj: Kernel.Object; o, v, lev, j, a: INTEGER; m: Kernel.Module; n: Kernel.Name; + BEGIN + IF in.ext # NIL THEN in.ext.Lookup(name, i); RETURN END; + ASSERT(in.ptr # NIL, 20); + IF LegalName(name) THEN + IF in.obj = modObj THEN + n := SHORT(name$); + obj := Kernel.ThisObject(in.mod, n); + IF obj # NIL THEN + SetItem(i, obj, in.mod); i.ptr := dummy; + IF (i.vis = hidden) OR (i.obj < typObj) THEN SetUndef(i) END + ELSE SetUndef(i) + END + ELSIF in.typ = recTyp THEN + ASSERT(in.desc.mod.refcnt >= 0, 24); + lev := in.desc.id DIV 16 MOD 16; j := 0; + n := SHORT(name$); + REPEAT + obj := Kernel.ThisField(in.desc.base[j], n); INC(j) + UNTIL (obj # NIL) OR (j > lev); + IF obj # NIL THEN + o := in.obj; a := in.adr; v := in.vis; m := in.mod; + SetItem(i, obj, m); i.ptr := in.ptr; + IF i.vis # hidden THEN + IF o = varObj THEN + i.obj := varObj; INC(i.adr, a); i.mod := m; + IF v < i.vis THEN i.vis := v END + END + ELSE SetUndef(i) + END + ELSE SetUndef(i) + END + ELSE HALT(21) + END + ELSE SetUndef(i) + END + END Lookup; + + PROCEDURE (VAR i: Item) GetBaseType* (VAR base: Item), NEW; + VAR n: INTEGER; + BEGIN + ASSERT(i.ext = NIL, 31); + ASSERT(i.ptr # NIL, 20); + ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21); n := 0; + IF i.typ = recTyp THEN n := i.desc.id DIV 16 MOD 16 - 1 END; + IF n >= 0 THEN + base.obj := typObj; base.vis := undef; base.adr := undef; + base.mod := NIL; base.ptr := dummy; base.ext := NIL; + base.desc := i.desc.base[n]; + base.typ := TypOf(base.desc) + ELSE + SetUndef(base) + END + END GetBaseType; + + PROCEDURE (VAR rec: Item) GetThisBaseType* (level: INTEGER; VAR base: Item), NEW; + BEGIN + ASSERT(rec.ext = NIL, 31); + ASSERT(rec.ptr # NIL, 20); + ASSERT(rec.typ = recTyp, 21); + ASSERT((level >= 0) & (level < 16), 28); + IF level <= rec.desc.id DIV 16 MOD 16 THEN + base.obj := typObj; base.vis := undef; base.adr := undef; + base.mod := NIL; base.ptr := dummy; base.ext := NIL; + base.desc := rec.desc.base[level]; + base.typ := TypOf(base.desc) + ELSE + SetUndef(base) + END + END GetThisBaseType; + + PROCEDURE (VAR proc: Item) NumParam* (): INTEGER, NEW; + VAR sig: Kernel.Signature; + BEGIN + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21); + sig := SignatureOf(proc); + IF sig # NIL THEN RETURN sig.num ELSE RETURN -1 END + END NumParam; + + PROCEDURE (VAR proc: Item) GetParam* (n: INTEGER; VAR par: Item), NEW; + VAR sig: Kernel.Signature; + BEGIN + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21); + sig := SignatureOf(proc); + IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN + par.obj := parObj; par.adr := n; + par.vis := sig.par[n].id MOD 16; + par.mod := NIL; par.ptr := dummy; par.ext := NIL; + par.desc := sig.par[n].struct; par.typ := TypOf(par.desc) + ELSE + SetUndef(par) + END + END GetParam; + + PROCEDURE (VAR proc: Item) GetParamName* (n: INTEGER; OUT name: Name), NEW; + VAR sig: Kernel.Signature; mod: Kernel.Module; nm: Kernel.Name; + BEGIN + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + IF proc.obj = procObj THEN mod := proc.mod + ELSE ASSERT(proc.typ = procTyp, 21); mod := proc.desc.mod + END; + ASSERT(mod.refcnt >= 0, 23); + sig := SignatureOf(proc); + IF (sig # NIL) & (n >= 0) & (n < sig.num) THEN + Kernel.GetObjName(mod, SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(sig.par[n]) - 8), nm); + name := nm$ + ELSE + name := "" + END + END GetParamName; + + PROCEDURE (VAR proc: Item) GetReturnType* (VAR type: Item), NEW; + VAR sig: Kernel.Signature; + BEGIN + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + ASSERT((proc.obj = procObj) OR (proc.typ = procTyp), 21); + sig := SignatureOf(proc); + IF sig # NIL THEN + type.obj := typObj; type.vis := undef; type.adr := undef; + type.mod := NIL; type.ptr := dummy; type.ext := NIL; + type.desc := sig.retStruct; type.typ := TypOf(type.desc) + ELSE + SetUndef(type) + END + END GetReturnType; + + PROCEDURE (VAR rec: Item) Is* (IN type: Value): BOOLEAN, NEW; + VAR d: Kernel.Type; + BEGIN + ASSERT(rec.ext = NIL, 31); + ASSERT(rec.ptr # NIL, 20); + ASSERT(rec.typ = recTyp, 21); + WITH type: Item DO + ASSERT(type.ptr # NIL, 20); + ASSERT(type.typ = recTyp, 21); + d := type.desc + ELSE + d := DescOf(type); (* type of value rec *) + ASSERT(d.id DIV 16 MOD 16 = 1, 25); (* level of type = 1*) + ASSERT(d.fields.num = 1, 26); (* one field in type *) + d := d.fields.obj[0].struct; (* type of field *) + ASSERT(SYSTEM.VAL(INTEGER, d) DIV 256 # 0, 21); (* type is structured *) + IF d.id MOD 4 = 3 THEN d := d.base[0] END (* deref ptr *) + END; + RETURN rec.desc.base[d.id DIV 16 MOD 16] = d (* rec IS d *) + END Is; + + PROCEDURE (VAR ptr: Item) Deref* (VAR ref: Item), NEW; + BEGIN + IF ptr.ext # NIL THEN ptr.ext.Deref(ref); RETURN END; + ASSERT(ptr.ptr # NIL, 20); + ASSERT(ptr.typ IN {sysPtrTyp, anyPtrTyp, ptrTyp}, 21); + ASSERT(ptr.obj = varObj, 22); + ASSERT((ptr.mod = NIL) OR (ptr.mod.refcnt >= 0), 23); + SYSTEM.GET(ptr.adr, ref.adr); + IF ref.adr # 0 THEN + IF ptr.typ # ptrTyp THEN ref.typ := recTyp + ELSE ref.desc := ptr.desc.base[0]; ref.typ := TypOf(ref.desc) + END; + ref.obj := varObj; ref.mod := NIL; ref.vis := exported; (* !!! *) + ref.ptr := SYSTEM.VAL(ArrayPtr, ref.adr); + IF ref.typ = recTyp THEN + ref.desc := DescOf(ref.ptr^); (* dynamic type *) + ELSIF ref.typ = arrTyp THEN + ref.adr := SYSTEM.ADR(ref.ptr.len[ref.desc.id DIV 16 MOD 16]); (* descriptor offset *) + ELSE HALT(100) + END + ELSE SetUndef(ref) + END + END Deref; + + PROCEDURE (VAR arr: Item) Index* (index: INTEGER; VAR elem: Item), NEW; + BEGIN + IF arr.ext # NIL THEN arr.ext.Index(index, elem); RETURN END; + ASSERT(arr.ptr # NIL, 20); + ASSERT(arr.typ = arrTyp, 21); + ASSERT(arr.obj = varObj, 22); + IF (index >= 0) & (index < LenOf(arr)) THEN + elem.obj := varObj; elem.vis := arr.vis; + elem.mod := arr.mod; elem.ptr := arr.ptr; elem.ext := NIL; + elem.desc := arr.desc.base[0]; elem.typ := TypOf(elem.desc); + elem.adr := arr.adr + index * SizeOf(elem) + ELSE + SetUndef(elem) + END + END Index; + + PROCEDURE LookupPath* (IN path: ARRAY OF CHAR; OUT i: Item); + VAR j, n: INTEGER; name: Name; ch: CHAR; done: BOOLEAN; filter: FilterHook; + BEGIN + done := FALSE; filter := filterHook; + WHILE ~done & (filter # NIL) DO filter.filter(path, i, done); filter := filter.next END; + IF ~done THEN + j := 0; + GetName(path, name, j); + Lookup(name, i); + IF (i.obj = modObj) & (path[j] = ".") THEN + INC(j); GetName(path, name, j); + i.Lookup(name, i); ch := path[j]; INC(j); + WHILE (i.obj = varObj) & (ch # 0X) DO + IF i.typ = ptrTyp THEN i.Deref(i) END; + IF ch = "." THEN + GetName(path, name, j); + IF i.typ = recTyp THEN i.Lookup(name, i) ELSE SetUndef(i) END + ELSIF ch = "[" THEN + n := 0; ch := path[j]; INC(j); + WHILE (ch >= "0") & (ch <= "9") DO n := 10 * n + ORD(ch) - ORD("0"); ch := path[j]; INC(j) END; + IF (ch = "]") & (i.typ = arrTyp) THEN i.Index(n, i) ELSE SetUndef(i) END + END; + ch := path[j]; INC(j) + END + END + END + END LookupPath; + + (* ---------- Scanner ---------- *) + + PROCEDURE (VAR s: Scanner) ConnectToMods*, NEW; + BEGIN + SetUndef(s.this); + s.this.ptr := dummy; + s.mod := Kernel.modList; + s.mode := modScan; + s.eos := FALSE + END ConnectToMods; + + PROCEDURE (VAR s: Scanner) ConnectTo* (IN obj: Item), NEW; + BEGIN + ASSERT(obj.ptr # NIL, 20); + SetUndef(s.this); s.vis := obj.vis; + s.this.ptr := obj.ptr; s.mod := obj.mod; s.idx := 0; + IF obj.obj = modObj THEN + ASSERT(s.mod.refcnt >= 0, 23); + s.mode := globScan + ELSIF obj.typ = recTyp THEN + ASSERT(obj.desc.mod.refcnt >= 0, 24); + s.desc := obj.desc; s.base := 0; + IF obj.obj = varObj THEN s.mode := recVarScan; s.adr := obj.adr + ELSE s.mode := recTypeScan + END + ELSE HALT(21) + END; + s.eos := FALSE + END ConnectTo; + + PROCEDURE (VAR s: Scanner) Scan*, NEW; + VAR desc: Kernel.Type; + BEGIN + ASSERT(s.this.ptr # NIL, 20); + IF s.mode = modScan THEN + IF s.mod # NIL THEN SetMod(s.this, s.mod); s.mod := s.mod.next + ELSE SetUndef(s.this); s.eos := TRUE + END + ELSIF s.mode = globScan THEN + ASSERT(s.mod.refcnt >= 0, 23); + REPEAT + IF s.idx >= s.mod.export.num THEN SetUndef(s.this); s.eos := TRUE; RETURN END; + s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(s.mod.export.obj[s.idx])); + SetItem(s.this, s.obj, s.mod); INC(s.idx) + UNTIL (s.this.obj IN {procObj, varObj, typObj}) & (s.this.vis # hidden) + ELSE + ASSERT(s.desc.mod.refcnt >= 0, 24); + desc := s.desc.base[s.base]; + REPEAT + WHILE s.idx >= desc.fields.num DO + IF desc = s.desc THEN SetUndef(s.this); s.eos := TRUE; RETURN END; + INC(s.base); desc := s.desc.base[s.base]; s.idx := 0 + END; + s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(desc.fields.obj[s.idx])); + SetItem(s.this, s.obj, s.mod); INC(s.idx) + UNTIL s.this.vis # hidden; + IF s.mode = recVarScan THEN + s.this.obj := varObj; INC(s.this.adr, s.adr); s.this.mod := s.mod; + IF s.vis < s.this.vis THEN s.this.vis := s.vis END + END + END + END Scan; + + PROCEDURE (VAR s: Scanner) GetObjName* (OUT name: Name), NEW; + VAR mod: Kernel.Module; n: Kernel.Name; + BEGIN + ASSERT(s.this.ptr # NIL, 20); + IF s.mode = modScan THEN + name := s.this.mod.name$ (* mf 24.08.2004 *) + ELSE + IF s.mode = globScan THEN mod := s.mod + ELSE mod := s.desc.base[s.base].mod + END; + ASSERT(mod.refcnt >= 0, 23); + Kernel.GetObjName(mod, s.obj, n); + name := n$; + END + END GetObjName; + + PROCEDURE (VAR s: Scanner) Level* (): INTEGER, NEW; + BEGIN + ASSERT(s.this.ptr # NIL, 20); + ASSERT(s.mode >= recVarScan, 22); + RETURN s.base + END Level; + + (* ---------- access to item values ---------- *) + + PROCEDURE ValToItem (IN x: Value; VAR i: Item); + VAR desc: Kernel.Type; + BEGIN + desc := DescOf(x); + ASSERT(desc.id DIV 16 MOD 16 = 1, 25); (* level of x = 1*) + ASSERT(desc.fields.num = 1, 26); (* one field in x *) + i.desc := desc.fields.obj[0].struct; + i.typ := TypOf(i.desc); i.obj := varObj; i.ext := NIL; i.vis := exported; + i.ptr := dummy; i.adr := SYSTEM.ADR(x) + END ValToItem; + + PROCEDURE^ EqualSignature (a, b: Kernel.Signature): BOOLEAN; + + PROCEDURE EqualType (a, b: Kernel.Type): BOOLEAN; + BEGIN + LOOP + IF a = b THEN RETURN TRUE END; + IF (SYSTEM.VAL(INTEGER, a) DIV 256 = 0) + OR (SYSTEM.VAL(INTEGER, b) DIV 256 = 0) + OR (a.id MOD 4 # b.id MOD 4) THEN RETURN FALSE END; + CASE a.id MOD 4 OF + | recTyp - 16: RETURN FALSE + | arrTyp - 16: IF (a.size # 0) OR (b.size # 0) THEN RETURN FALSE END + | procTyp - 16: RETURN EqualSignature(SYSTEM.VAL(Kernel.Signature, a.base[0]), + SYSTEM.VAL(Kernel.Signature, b.base[0])) + ELSE (* ptrTyp *) + END; + a := a.base[0]; b := b.base[0] + END + END EqualType; + + PROCEDURE EqualSignature (a, b: Kernel.Signature): BOOLEAN; + VAR i: INTEGER; + BEGIN + IF (a.num # b.num) OR ~EqualType(a.retStruct, b.retStruct) THEN RETURN FALSE END; + i := 0; + WHILE i < a.num DO + IF (a.par[i].id MOD 256 # b.par[i].id MOD 256) + OR ~EqualType(a.par[i].struct, b.par[i].struct) THEN RETURN FALSE END; + INC(i) + END; + RETURN TRUE + END EqualSignature; + + PROCEDURE Copy (IN a, b: Item; OUT ok: BOOLEAN); (* b := a *) + VAR n: INTEGER; at, bt: Item; + BEGIN + ok := FALSE; + IF a.obj = procObj THEN + IF (b.typ # procTyp) + OR ~EqualSignature(SignatureOf(a), SignatureOf(b)) THEN RETURN END; + SYSTEM.PUT(b.adr, a.adr); + ELSE (* a.obj = varObj *) + IF a.typ # b.typ THEN RETURN END; + IF a.typ >= recTyp THEN + IF a.typ = ptrTyp THEN + at.desc := a.desc.base[0]; at.typ := TypOf(at.desc); at.ptr := dummy; at.ext := NIL; + bt.desc := b.desc.base[0]; bt.typ := TypOf(bt.desc); bt.ptr := dummy; bt.ext := NIL; + SYSTEM.GET(a.adr, n); + IF (at.typ = recTyp) & (n # 0) THEN + SYSTEM.GET(SYSTEM.VAL(INTEGER, n) - 4, at.desc); (* dynamic type *) + at.desc := at.desc.base[bt.desc.id DIV 16 MOD 16] (* projection to b *) + END + ELSE at := a; bt := b + END; + WHILE (at.typ = arrTyp) & (bt.typ = arrTyp) DO + IF LenOf(at) # LenOf(bt) THEN RETURN END; + at.desc := at.desc.base[0]; at.typ := TypOf(at.desc); + bt.desc := bt.desc.base[0]; bt.typ := TypOf(bt.desc) + END; + IF (at.desc # bt.desc) & + ~((at.typ = procTyp) & (bt.typ = procTyp) + & EqualSignature(SignatureOf(at), SignatureOf(bt))) THEN RETURN END + END; + SYSTEM.MOVE(a.adr, b.adr, SizeOf(b)) + END; + ok := TRUE + END Copy; + + PROCEDURE (VAR proc: Item) Call* (OUT ok: BOOLEAN), NEW; + VAR p: Kernel.Command; sig: Kernel.Signature; + BEGIN + IF proc.ext # NIL THEN proc.ext.Call(ok); RETURN END; + ASSERT(proc.ptr # NIL, 20); + IF proc.obj = procObj THEN + p := SYSTEM.VAL(Kernel.Command, proc.adr) + ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22); + SYSTEM.GET(proc.adr, p) + END; + ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23); + sig := SignatureOf(proc); + IF (sig.retStruct = NIL) & (sig.num = 0) & (p # NIL) THEN p(); ok := TRUE + ELSE ok := FALSE + END + END Call; + + PROCEDURE PutParam (IN par: Item; sig: Kernel.Signature; p: INTEGER; + VAR data: ARRAY OF INTEGER; VAR n: INTEGER; + OUT ok: BOOLEAN); (* check & assign a parameter *) + VAR mode, fTyp, aTyp, padr, i: INTEGER; fDesc, aDesc: Kernel.Type; + l: LONGINT; s: SHORTINT; b: BYTE; + BEGIN + ok := FALSE; + ASSERT(par.ext = NIL, 31); + ASSERT(par.ptr # NIL, 20); + ASSERT(par.obj = varObj, 22); + ASSERT((par.mod = NIL) OR (par.mod.refcnt >= 0), 23); + mode := sig.par[p].id MOD 16; + IF mode >= out THEN ASSERT(par.vis = exported, 27) END; + fDesc := sig.par[p].struct; + fTyp := TypOf(fDesc); + aDesc := par.desc; + aTyp := TypOf(aDesc); + padr := par.adr; + IF (fTyp = recTyp) OR (fTyp = anyRecTyp) THEN + IF (aTyp # recTyp) + OR (mode = value) & (aDesc # fDesc) + OR (fTyp = recTyp) & (aDesc.base[fDesc.id DIV 16 MOD 16] # fDesc) THEN RETURN END; + data[n] := padr; INC(n); + data[n] := SYSTEM.VAL(INTEGER, aDesc); INC(n) + ELSIF fTyp = arrTyp THEN + data[n] := padr; INC(n); + IF fDesc.size # 0 THEN data[n] := SizeOf(par); INC(n) END; + WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO + IF aDesc.size # 0 THEN i := aDesc.size (* actual static size *) + ELSE i := par.ptr.len[aDesc.id DIV 16 MOD 16 - 1] (* actual dynamic size *) + END; + IF fDesc.size = 0 THEN data[n] := i; INC(n) + ELSIF fDesc.size # i THEN RETURN + END; + fDesc := fDesc.base[0]; aDesc := aDesc.base[0] + END; + IF fDesc # aDesc THEN RETURN END + ELSIF fTyp >= anyPtrTyp THEN (* pointer *) + IF fTyp = ptrTyp THEN + fDesc := fDesc.base[0]; (* formal base type *) + IF (mode = value) & (TypOf(fDesc) = recTyp) THEN + IF (aTyp # ptrTyp) & (aTyp # anyPtrTyp) THEN RETURN END; + SYSTEM.GET(padr, i); SYSTEM.GET(i - 4, aDesc); (* dynamic record type *) + aDesc := aDesc.base[fDesc.id DIV 16 MOD 16] (* projection *) + ELSE + IF aTyp # ptrTyp THEN RETURN END; + aDesc := aDesc.base[0]; (* actual base type *) + WHILE (TypOf(fDesc) = arrTyp) & (TypOf(aDesc) = arrTyp) DO + IF fDesc.size # aDesc.size THEN RETURN END; + fDesc := fDesc.base[0]; aDesc := aDesc.base[0] + END + END; + IF fDesc # aDesc THEN RETURN END + ELSIF fTyp = anyPtrTyp THEN + IF (aTyp # anyPtrTyp) & ((aTyp # ptrTyp) OR (TypOf(aDesc.base[0]) # recTyp)) THEN RETURN END + ELSIF fTyp = procTyp THEN + IF (aTyp # procTyp) OR (fDesc.size # aDesc.size) THEN RETURN END (* same fingerprint *) + END; + IF mode = value THEN SYSTEM.GET(padr, data[n]); INC(n) + ELSE data[n] := padr; INC(n) + END + ELSE (* basic type *) + IF fTyp # aTyp THEN RETURN END; + IF mode = value THEN + CASE SizeOf(par) OF + | 1: SYSTEM.GET(padr, b); data[n] := b; INC(n) + | 2: SYSTEM.GET(padr, s); data[n] := s; INC(n) + | 4: SYSTEM.GET(padr, i); data[n] := i; INC(n) + | 8: SYSTEM.GET(padr, l); data[n] := SHORT(l); INC(n); data[n] := SHORT(l DIV 100000000L); INC(n) + END + ELSE (* var par *) + data[n] := padr; INC(n) + END + END; + ok := TRUE + END PutParam; + + PROCEDURE GetResult (ret: LONGINT; VAR dest: Item; sig: Kernel.Signature; + OUT ok: BOOLEAN); (* assign return value *) + VAR x: Item; i: INTEGER; s: SHORTINT; b: BYTE; + BEGIN + ASSERT(dest.ext = NIL, 31); + ASSERT(dest.ptr # NIL, 20); + ASSERT(dest.obj = varObj, 22); + ASSERT((dest.mod = NIL) OR (dest.mod.refcnt >= 0), 23); + ASSERT(dest.vis = exported, 27); + x.desc := sig.retStruct; x.typ := TypOf(x.desc); + x.obj := varObj; x.ptr := dummy; + CASE TypOf(sig.retStruct) OF + | boolTyp, sCharTyp, byteTyp: b := SHORT(SHORT(SHORT(ret))); x.adr := SYSTEM.ADR(b); + | charTyp, sIntTyp: s := SHORT(SHORT(ret)); x.adr := SYSTEM.ADR(s); + | longTyp, realTyp: x.adr := SYSTEM.ADR(ret); + | intTyp, sRealTyp, setTyp, anyPtrTyp, procTyp, ptrTyp: i := SHORT(ret); x.adr := SYSTEM.ADR(i); + END; + Copy(x, dest, ok) + END GetResult; + + PROCEDURE (VAR proc: Item) ParamCall* (IN par: ARRAY OF Item; VAR dest: Item; + OUT ok: BOOLEAN), NEW; + VAR n, p, adr, padr: INTEGER; ret: LONGINT; + data: ARRAY 256 OF INTEGER; sig: Kernel.Signature; + BEGIN + ok := TRUE; + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + IF proc.obj = procObj THEN adr := proc.adr + ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22); + SYSTEM.GET(proc.adr, adr); + IF adr = 0 THEN ok := FALSE; RETURN END + END; + ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23); + sig := SignatureOf(proc); + ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32); + n := 0; p := 0; + WHILE ok & (p < sig.num) DO (* check & assign parameters *) + PutParam(par[p], sig, p, data, n, ok); + INC(p) + END; + IF ok THEN + ret := Kernel.Call(adr, sig, data, n); + IF sig.retStruct # NIL THEN GetResult(ret, dest, sig, ok) END + END + END ParamCall; + + PROCEDURE (VAR proc: Item) ParamCallVal* (IN par: ARRAY OF POINTER TO Value; VAR dest: Value; + OUT ok: BOOLEAN), NEW; + TYPE IP = POINTER TO Item; + VAR n, p, adr, padr: INTEGER; ret: LONGINT; x: Item; + data: ARRAY 256 OF INTEGER; sig: Kernel.Signature; + BEGIN + ok := TRUE; + ASSERT(proc.ext = NIL, 31); + ASSERT(proc.ptr # NIL, 20); + IF proc.obj = procObj THEN adr := proc.adr + ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22); + SYSTEM.GET(proc.adr, adr); + IF adr = 0 THEN ok := FALSE; RETURN END + END; + ASSERT((proc.mod = NIL) OR (proc.mod.refcnt >= 0), 23); + sig := SignatureOf(proc); + ASSERT((sig # NIL) & (LEN(par) >= sig.num), 32); + n := 0; p := 0; + WHILE ok & (p < sig.num) DO (* check & assign parameters *) + IF par[p] IS IP THEN + PutParam(par[p](IP)^, sig, p, data, n, ok) + ELSE + ValToItem(par[p]^, x); + PutParam(x, sig, p, data, n, ok) + END; + INC(p) + END; + IF ok THEN + ret := Kernel.Call(adr, sig, data, n); + IF sig.retStruct # NIL THEN + WITH dest: Item DO + GetResult(ret, dest, sig, ok) + ELSE + ValToItem(dest, x); + GetResult(ret, x, sig, ok) + END + END + END + END ParamCallVal; + + PROCEDURE (VAR var: Item) GetVal* (VAR x: Value; OUT ok: BOOLEAN), NEW; + VAR xi: Item; + BEGIN + ASSERT(var.ext = NIL, 31); + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj IN {varObj, procObj}, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + WITH x: Item DO + ASSERT(x.ptr # NIL, 20); + ASSERT(x.obj = varObj, 22); + ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23); + ASSERT(x.vis = exported, 27); + Copy(var, x, ok) + ELSE + ValToItem(x, xi); Copy(var, xi, ok) + END + END GetVal; + + PROCEDURE (VAR var: Item) PutVal* (IN x: Value; OUT ok: BOOLEAN), NEW; + VAR xi: Item; + BEGIN + ASSERT(var.ext = NIL, 31); + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + WITH x: Item DO + ASSERT(x.ptr # NIL, 20); + ASSERT(x.obj IN {varObj, procObj}, 22); + ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23); + Copy(x, var, ok) + ELSE + ValToItem(x, xi); Copy(xi, var, ok) + END + END PutVal; + + PROCEDURE (VAR var: Item) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW; + VAR i, n: INTEGER; p: StringPtr; + BEGIN + IF var.ext # NIL THEN var.ext.GetStringVal(x, ok); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + p := SYSTEM.VAL(StringPtr, var.adr); i := 0; n := LenOf(var); + WHILE (i < n) & (p[i] # 0X) DO INC(i) END; + IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE + ELSE x := ""; ok := FALSE + END + END GetStringVal; + + PROCEDURE (VAR var: Item) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW; + VAR i, n: INTEGER; p: SStringPtr; + BEGIN + IF var.ext # NIL THEN var.ext.GetSStringVal(x, ok); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + p := SYSTEM.VAL(SStringPtr, var.adr); i := 0; n := LenOf(var); + WHILE (i < n) & (p[i] # 0X) DO INC(i) END; + IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE + ELSE x := ""; ok := FALSE + END + END GetSStringVal; + + PROCEDURE (VAR var: Item) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW; + VAR i: INTEGER; p: StringPtr; + BEGIN + IF var.ext # NIL THEN var.ext.PutStringVal(x, ok); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + p := SYSTEM.VAL(StringPtr, var.adr); i := 0; + WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END; + IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE + ELSE ok := FALSE + END + END PutStringVal; + + PROCEDURE (VAR var: Item) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW; + VAR i: INTEGER; p: SStringPtr; + BEGIN + IF var.ext # NIL THEN var.ext.PutSStringVal(x, ok); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + p := SYSTEM.VAL(SStringPtr, var.adr); i := 0; + WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END; + IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE + ELSE ok := FALSE + END + END PutSStringVal; + + PROCEDURE (VAR var: Item) PtrVal* (): ANYPTR, NEW; + VAR p: ANYPTR; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.PtrVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + SYSTEM.GET(var.adr, p); + RETURN p + END PtrVal; + + PROCEDURE (VAR var: Item) PutPtrVal* (x: ANYPTR), NEW; + VAR vt, xt: Kernel.Type; + BEGIN + IF var.ext # NIL THEN var.ext.PutPtrVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + IF (x # NIL) & (var.typ = ptrTyp) THEN + vt := var.desc.base[0]; xt := Kernel.TypeOf(x); + ASSERT(xt.base[vt.id DIV 16 MOD 16] = vt, 28); (* xt IS vt *) + END; + SYSTEM.PUT(var.adr, x) + END PutPtrVal; + + PROCEDURE (VAR var: Item) IntVal* (): INTEGER, NEW; + VAR sc: SHORTCHAR; ch: CHAR; s: BYTE; i: SHORTINT; x: INTEGER; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.IntVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, sc); x := ORD(sc) + ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, ch); x := ORD(ch) + ELSIF var.typ = byteTyp THEN SYSTEM.GET(var.adr, s); x := s + ELSIF var.typ = sIntTyp THEN SYSTEM.GET(var.adr, i); x := i + ELSIF var.typ = intTyp THEN SYSTEM.GET(var.adr, x) + ELSE HALT(21) + END; + RETURN x + END IntVal; + + PROCEDURE (VAR var: Item) PutIntVal* (x: INTEGER), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutIntVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(CHR(x))) + ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, CHR(x)) + ELSIF var.typ = byteTyp THEN SYSTEM.PUT(var.adr, SHORT(SHORT(x))) + ELSIF var.typ = sIntTyp THEN SYSTEM.PUT(var.adr, SHORT(x)) + ELSIF var.typ = intTyp THEN SYSTEM.PUT(var.adr, x) + ELSE HALT(21) + END + END PutIntVal; + + PROCEDURE (VAR var: Item) RealVal* (): REAL, NEW; + VAR r: SHORTREAL; x: REAL; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.RealVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + IF var.typ = sRealTyp THEN SYSTEM.GET(var.adr, r); x := r + ELSIF var.typ = realTyp THEN SYSTEM.GET(var.adr, x) + ELSE HALT(21) + END; + RETURN x + END RealVal; + + PROCEDURE (VAR var: Item) PutRealVal* (x: REAL), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutRealVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + IF var.typ = sRealTyp THEN SYSTEM.PUT(var.adr, SHORT(x)) + ELSIF var.typ = realTyp THEN SYSTEM.PUT(var.adr, x) + ELSE HALT(21) + END + END PutRealVal; + + PROCEDURE (VAR var: Item) LongVal* (): LONGINT, NEW; + VAR x: LONGINT; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.LongVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = longTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + SYSTEM.GET(var.adr, x); + RETURN x + END LongVal; + + PROCEDURE (VAR var: Item) PutLongVal* (x: LONGINT), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutLongVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = longTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + SYSTEM.PUT(var.adr, x) + END PutLongVal; + + PROCEDURE (VAR var: Item) CharVal* (): CHAR, NEW; + VAR x: CHAR; s: SHORTCHAR; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.CharVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, s); x := s + ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, x) + ELSE HALT(21) + END; + RETURN x + END CharVal; + + PROCEDURE (VAR var: Item) PutCharVal* (x: CHAR), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutCharVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(x)) + ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, x) + ELSE HALT(21) + END + END PutCharVal; + + PROCEDURE (VAR var: Item) BoolVal* (): BOOLEAN, NEW; + VAR x: BOOLEAN; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.BoolVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = boolTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + SYSTEM.GET(var.adr, x); + RETURN x + END BoolVal; + + PROCEDURE (VAR var: Item) PutBoolVal* (x: BOOLEAN), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutBoolVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = boolTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + SYSTEM.PUT(var.adr, x) + END PutBoolVal; + + PROCEDURE (VAR var: Item) SetVal* (): SET, NEW; + VAR x: SET; + BEGIN + IF var.ext # NIL THEN RETURN var.ext.SetVal() END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = setTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + SYSTEM.GET(var.adr, x); + RETURN x + END SetVal; + + PROCEDURE (VAR var: Item) PutSetVal* (x: SET), NEW; + BEGIN + IF var.ext # NIL THEN var.ext.PutSetVal(x); RETURN END; + ASSERT(var.ptr # NIL, 20); + ASSERT(var.typ = setTyp, 21); + ASSERT(var.obj = varObj, 22); + ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23); + ASSERT(var.vis = exported, 27); + SYSTEM.PUT(var.adr, x) + END PutSetVal; + + PROCEDURE (VAR type: Item) New* (): ANYPTR, NEW; + VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory; desc: Kernel.Type; + BEGIN + ASSERT(type.ext = NIL, 31); + ASSERT(type.ptr # NIL, 20); + desc := type.desc; + IF type.typ = ptrTyp THEN desc := desc.base[0] END; + ASSERT(TypOf(desc) = recTyp, 21); + ASSERT(desc.mod.refcnt >= 0, 24); + i := 0; d := type.desc.mod.export; n := d.num; id := type.desc.id DIV 256; + WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END; + ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29); + ASSERT(desc.id DIV 4 MOD 4 < limited, 30); + Kernel.NewObj(p, desc); + RETURN p + END New; + + PROCEDURE (VAR val: Item) Copy* (): ANYPTR, NEW; + VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory; + BEGIN + ASSERT(val.ext = NIL, 31); + ASSERT(val.ptr # NIL, 20); + ASSERT(val.typ = recTyp, 21); + ASSERT(val.obj = varObj, 22); + ASSERT(val.desc.mod.refcnt >= 0, 24); + i := 0; d := val.desc.mod.export; n := d.num; id := val.desc.id DIV 256; + WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END; + ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29); + ASSERT(val.desc.id DIV 4 MOD 4 < limited, 30); + Kernel.NewObj(p, val.desc); + SYSTEM.MOVE(val.adr, p, val.desc.size); + RETURN p + END Copy; + + PROCEDURE (VAR rec: Item) CallWith* (proc: PROCEDURE(VAR rec, par: ANYREC); VAR par: ANYREC), NEW; + BEGIN + ASSERT(rec.ext = NIL, 31); + ASSERT(rec.ptr # NIL, 20); + ASSERT(rec.typ = recTyp, 21); + ASSERT(rec.obj = varObj, 22); + ASSERT((rec.mod = NIL) OR (rec.mod.refcnt >= 0), 23); + proc(SYSTEM.THISRECORD(rec.adr, SYSTEM.VAL(INTEGER, rec.desc)), par) + END CallWith; + + + PROCEDURE InstallFilter* (filter: LookupFilter); + VAR h: FilterHook; + BEGIN + ASSERT(filter # NIL, 20); + NEW(h); h.filter := filter; h.next := filterHook; filterHook := h + END InstallFilter; + + PROCEDURE UninstallFilter* (filter: LookupFilter); + VAR h, a: FilterHook; + BEGIN + ASSERT(filter # NIL, 20); + h := filterHook; a := NIL; + WHILE (h # NIL) & (h.filter # filter) DO a := h; h := h.next END; + IF h # NIL THEN + IF a = NIL THEN filterHook := h.next ELSE a.next := h.next END + END + END UninstallFilter; + + PROCEDURE GetThisItem* (IN attr: ANYREC; OUT i: Item); + BEGIN + WITH attr: Kernel.ItemAttr DO + i.obj := attr.obj; i.vis := attr.vis; i.typ := attr.typ; i.adr := attr.adr; + i.mod := attr.mod; i.desc := attr.desc; i.ptr := attr.ptr; i.ext := attr.ext; + IF i.ptr = NIL THEN i.ptr := dummy END + END + END GetThisItem; + +BEGIN + NEW(dummy) +END Meta. diff --git a/Trurl-based/System/Mod/Models.txt b/Trurl-based/System/Mod/Models.txt new file mode 100644 index 0000000..c3b1ba9 --- /dev/null +++ b/Trurl-based/System/Mod/Models.txt @@ -0,0 +1,258 @@ +MODULE Models; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Models.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, Stores, Sequencers; + + CONST + minVersion = 0; maxVersion = 0; + + clean* = Sequencers.clean; + notUndoable* = Sequencers.notUndoable; + invisible* = Sequencers.invisible; + + TYPE + Model* = POINTER TO ABSTRACT RECORD (Stores.Store) + era: INTEGER; (* stable era >= x *) + guard: INTEGER (* = TrapCount()+1 if model is addressee of ongoing broadcast *) + END; + + Context* = POINTER TO ABSTRACT RECORD END; + + Proposal* = ABSTRACT RECORD END; + + + Message* = ABSTRACT RECORD + model-: Model; + era-: INTEGER + END; + + NeutralizeMsg* = RECORD (Message) END; + + UpdateMsg* = EXTENSIBLE RECORD (Message) END; + + + VAR domainGuard: INTEGER; (* = TrapCount()+1 if domain is addressee of ongoing domaincast *) + + + (** Model **) + + PROCEDURE (m: Model) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + m.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion) + END Internalize; + + PROCEDURE (m: Model) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + m.Externalize^(wr); + wr.WriteVersion(maxVersion) + END Externalize; + + + (** Context **) + + PROCEDURE (c: Context) ThisModel* (): Model, NEW, ABSTRACT; + PROCEDURE (c: Context) Normalize* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (c: Context) GetSize* (OUT w, h: INTEGER), NEW, ABSTRACT; + PROCEDURE (c: Context) SetSize* (w, h: INTEGER), NEW, EMPTY; + PROCEDURE (c: Context) MakeVisible* (l, t, r, b: INTEGER), NEW, EMPTY; + PROCEDURE (c: Context) Consider* (VAR p: Proposal), NEW, EMPTY; + + + (** miscellaneous **) + + PROCEDURE Era* (m: Model): INTEGER; + BEGIN + ASSERT(m # NIL, 20); + RETURN m.era + END Era; + + + PROCEDURE CopyOf* (m: Model): Model; + BEGIN + ASSERT(m # NIL, 20); + RETURN Stores.CopyOf(m)(Model) + END CopyOf; + + PROCEDURE BeginScript* (m: Model; name: Stores.OpName; OUT script: Stores.Operation); + (** post: (script # NIL) iff (m.domain # NIL) **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.BeginScript(name, script) + ELSE + END + ELSE script := NIL + END + END BeginScript; + + PROCEDURE Do* (m: Model; name: Stores.OpName; op: Stores.Operation); + (** pre: m # NIL, op # NIL, ~op.inUse **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); ASSERT(op # NIL, 21); (* ASSERT(~op.inUse, 22); *) + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.Do(m, name, op) + ELSE + op.Do + END + ELSE + op.Do + END + END Do; + + PROCEDURE LastOp* (m: Model): Stores.Operation; + (** pre: m # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + RETURN seq.LastOp(m) + ELSE + RETURN NIL + END + ELSE + RETURN NIL + END + END LastOp; + + PROCEDURE Bunch* (m: Model); + (** pre: m # NIL, m.Domain() # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); ASSERT(m.Domain() # NIL, 21); + seq := m.Domain().GetSequencer(); + ASSERT(seq # NIL, 22); + WITH seq: Sequencers.Sequencer DO + seq.Bunch(m) + ELSE + END + END Bunch; + + PROCEDURE StopBunching* (m: Model); + (** pre: m # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.StopBunching + ELSE + END + END + END StopBunching; + + PROCEDURE EndScript* (m: Model; script: Stores.Operation); + (** pre: (script # NIL) iff (m.seq # NIL) **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + ASSERT(script # NIL, 21); + WITH seq: Sequencers.Sequencer DO + seq.EndScript(script) + ELSE + ASSERT(script = NIL, 21) + END + ELSE + ASSERT(script = NIL, 21) + END + END EndScript; + + + PROCEDURE BeginModification* (type: INTEGER; m: Model); + (** pre: m # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.BeginModification(type, m) + ELSE + END + END + END BeginModification; + + PROCEDURE EndModification* (type: INTEGER; m: Model); + (** pre: m # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.EndModification(type, m) + ELSE + END + END + END EndModification; + + PROCEDURE SetDirty* (m: Model); + (** pre: m # NIL **) + VAR seq: ANYPTR; + BEGIN + ASSERT(m # NIL, 20); + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + seq.SetDirty(TRUE) + ELSE + END + END + END SetDirty; + + PROCEDURE Domaincast* (d: Stores.Domain; VAR msg: Message); + VAR g: INTEGER; seq: ANYPTR; + BEGIN + IF d # NIL THEN + seq := d.GetSequencer(); + IF (seq # NIL) & (seq IS Sequencers.Sequencer) THEN + msg.model := NIL; msg.era := -1; + g := Kernel.trapCount + 1; + IF domainGuard > 0 THEN ASSERT(domainGuard # g, 20) END; + domainGuard := g; + seq(Sequencers.Sequencer).Handle(msg); + domainGuard := 0 + END + END + END Domaincast; + + PROCEDURE Broadcast* (m: Model; VAR msg: Message); + (** pre: model # NIL **) + (** post: model.era > model.era', msg.model = model, msg.era = model.era' + 1, + model.seq # NIL => msg sent to seq **) + VAR seq: ANYPTR; g: INTEGER; + BEGIN + ASSERT(m # NIL, 20); + msg.model := m; + IF m.Domain() # NIL THEN seq := m.Domain().GetSequencer() ELSE seq := NIL END; + IF seq # NIL THEN + WITH seq: Sequencers.Sequencer DO + INC(m.era); msg.era := m.era; + g := Kernel.trapCount + 1; + IF m.guard > 0 THEN ASSERT(m.guard # g, 21) END; + m.guard := g; + seq.Handle(msg); + m.guard := 0 + ELSE + END + END + END Broadcast; + +BEGIN + domainGuard := 0 +END Models. diff --git a/Trurl-based/System/Mod/Ports.txt b/Trurl-based/System/Mod/Ports.txt new file mode 100644 index 0000000..93731f7 --- /dev/null +++ b/Trurl-based/System/Mod/Ports.txt @@ -0,0 +1,318 @@ +MODULE Ports; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Ports.odc *) + (* DO NOT EDIT *) + + IMPORT Fonts; + + CONST + (** colors **) + black* = 00000000H; white* = 00FFFFFFH; + grey6* = 00F0F0F0H; grey12* = 00E0E0E0H; grey25* = 00C0C0C0H; + grey50* = 00808080H; grey75* = 00404040H; + red* = 000000FFH; green* = 0000FF00H; blue* = 00FF0000H; + defaultColor* = 01000000H; + + (** measures **) + mm* = 36000; + point* = 12700; + inch* = 914400; + + (** size parameter for the DrawRect, DrawOval, DrawLine, DrawPath, and MarkRect procedures **) + fill* = -1; + + (** path parameter for DrawPath **) + openPoly* = 0; closedPoly* = 1; openBezier* = 2; closedBezier* = 3; + + (** modes for MarkRect **) + invert* = 0; hilite* = 1; dim25* = 2; dim50* = 3; dim75* = 4; + + hide* = FALSE; show* = TRUE; + + (** cursors **) + arrowCursor* = 0; + textCursor* = 1; graphicsCursor* = 2; tableCursor* = 3; bitmapCursor* = 4; refCursor* = 5; + + (** RestoreRect **) + keepBuffer* = FALSE; disposeBuffer* = TRUE; + + + (** PageMode **) + printer* = TRUE; screen* = FALSE; + + + TYPE + Color* = INTEGER; + + Point* = RECORD + x*, y*: INTEGER + END; + + Port* = POINTER TO ABSTRACT RECORD + unit-: INTEGER; + printerMode: BOOLEAN; + END; + + Rider* = POINTER TO ABSTRACT RECORD END; + + Frame* = POINTER TO ABSTRACT RECORD + unit-, dot-: INTEGER; (** inv: dot = point - point MOD unit **) + rider-: Rider; + gx-, gy-: INTEGER + END; + + + VAR + background*: Color; + dialogBackground*: Color; + + + (** Port **) + + PROCEDURE (p: Port) Init* (unit: INTEGER; printerMode: BOOLEAN), NEW; + BEGIN + ASSERT((p.unit = 0) OR (p.unit = unit), 20); ASSERT(unit > 0, 21); + ASSERT((p.unit = 0) OR (p.printerMode = printerMode), 22); + p.unit := unit; + p.printerMode := printerMode; + END Init; + + PROCEDURE (p: Port) GetSize* (OUT w, h: INTEGER), NEW, ABSTRACT; + PROCEDURE (p: Port) SetSize* (w, h: INTEGER), NEW, ABSTRACT; + PROCEDURE (p: Port) NewRider* (): Rider, NEW, ABSTRACT; + PROCEDURE (p: Port) OpenBuffer* (l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (p: Port) CloseBuffer* (), NEW, ABSTRACT; + + + (** Rider **) + + PROCEDURE (rd: Rider) SetRect* (l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) GetRect* (OUT l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) Base* (): Port, NEW, ABSTRACT; + PROCEDURE (rd: Rider) Move* (dx, dy: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) SaveRect* (l, t, r, b: INTEGER; VAR res: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) RestoreRect* (l, t, r, b: INTEGER; dispose: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawRect* (l, t, r, b, s: INTEGER; col: Color), NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawOval* (l, t, r, b, s: INTEGER; col: Color), NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawLine* (x0, y0, x1, y1, s: INTEGER; col: Color), NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawPath* (IN p: ARRAY OF Point; n, s: INTEGER; col: Color; + path: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) MarkRect* (l, t, r, b, s, mode: INTEGER; show: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (rd: Rider) Scroll* (dx, dy: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) SetCursor* (cursor: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Rider) Input* (OUT x, y: INTEGER; OUT modifiers: SET; + OUT isDown: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawString* (x, y: INTEGER; col: Color; IN s: ARRAY OF CHAR; + font: Fonts.Font), NEW, ABSTRACT; + PROCEDURE (rd: Rider) CharIndex* (x, pos: INTEGER; IN s: ARRAY OF CHAR; + font: Fonts.Font): INTEGER, NEW, ABSTRACT; + PROCEDURE (rd: Rider) CharPos* (x, index: INTEGER; IN s: ARRAY OF CHAR; + font: Fonts.Font): INTEGER, NEW, ABSTRACT; + PROCEDURE (rd: Rider) DrawSString* (x, y: INTEGER; col: Color; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font), NEW, ABSTRACT; + PROCEDURE (rd: Rider) SCharIndex* (x, pos: INTEGER; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font): INTEGER, NEW, ABSTRACT; + PROCEDURE (rd: Rider) SCharPos* (x, index: INTEGER; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font): INTEGER, NEW, ABSTRACT; + + + (** Frame **) + + PROCEDURE (f: Frame) ConnectTo* (p: Port), NEW, EXTENSIBLE; + VAR w, h: INTEGER; + BEGIN + IF p # NIL THEN + f.rider := p.NewRider(); f.unit := p.unit; + p.GetSize(w, h); + f.dot := point - point MOD f.unit; + ELSE + f.rider := NIL; f.unit := 0 + END + END ConnectTo; + + PROCEDURE (f: Frame) SetOffset* (gx, gy: INTEGER), NEW, EXTENSIBLE; + VAR u: INTEGER; + BEGIN + u := f.unit; + IF ((gx - f.gx) MOD u = 0) & ((gy - f.gy) MOD u = 0) THEN + f.rider.Move((gx - f.gx) DIV u, (gy - f.gy) DIV u) + END; + f.gx := gx; f.gy := gy + END SetOffset; + + PROCEDURE (f: Frame) SaveRect* (l, t, r, b: INTEGER; VAR res: INTEGER), NEW; + VAR u: INTEGER; + BEGIN + ASSERT((l <= r) & (t <= b), 20); + u := f.unit; + l := (f.gx + l) DIV u; t := (f.gy + t) DIV u; + r := (f.gx + r) DIV u; b := (f.gy + b) DIV u; + f.rider.SaveRect(l, t, r, b, res); + END SaveRect; + + PROCEDURE (f: Frame) RestoreRect* (l, t, r, b: INTEGER; dispose: BOOLEAN), NEW; + VAR u: INTEGER; + BEGIN + ASSERT((l <= r) & (t <= b), 20); + u := f.unit; + l := (f.gx + l) DIV u; t := (f.gy + t) DIV u; + r := (f.gx + r) DIV u; b := (f.gy + b) DIV u; + f.rider.RestoreRect(l, t, r, b, dispose); + END RestoreRect; + + PROCEDURE (f: Frame) DrawRect* (l, t, r, b, s: INTEGER; col: Color), NEW; + VAR u: INTEGER; + BEGIN + ASSERT((l <= r) & (t <= b), 20); ASSERT(s >= fill, 21); + u := f.unit; + l := (f.gx + l) DIV u; t := (f.gy + t) DIV u; + r := (f.gx + r) DIV u; b := (f.gy + b) DIV u; + s := s DIV u; + f.rider.DrawRect(l, t, r, b, s, col) + END DrawRect; + + PROCEDURE (f: Frame) DrawOval* (l, t, r, b, s: INTEGER; col: Color), NEW; + VAR u: INTEGER; + BEGIN + ASSERT((l <= r) & (t <= b), 20); ASSERT(s >= fill, 21); + u := f.unit; + l := (f.gx + l) DIV u; t := (f.gy + t) DIV u; + r := (f.gx + r) DIV u; b := (f.gy + b) DIV u; + s := s DIV u; + f.rider.DrawOval(l, t, r, b, s, col) + END DrawOval; + + PROCEDURE (f: Frame) DrawLine* (x0, y0, x1, y1, s: INTEGER; col: Color), NEW; + VAR u: INTEGER; + BEGIN + ASSERT(s >= fill, 20); + u := f.unit; + x0 := (f.gx + x0) DIV u; y0 := (f.gy + y0) DIV u; + x1 := (f.gx + x1) DIV u; y1 := (f.gy + y1) DIV u; + s := s DIV u; + f.rider.DrawLine(x0, y0, x1, y1, s, col) + END DrawLine; + + PROCEDURE (f: Frame) DrawPath* (IN p: ARRAY OF Point; n, s: INTEGER; col: Color; path: INTEGER), NEW; + + PROCEDURE Draw(p: ARRAY OF Point); + VAR i, u: INTEGER; + BEGIN + u := f.unit; s := s DIV u; + i := 0; + WHILE i # n DO + p[i].x := (f.gx + p[i].x) DIV u; p[i].y := (f.gy + p[i].y) DIV u; + INC(i) + END; + f.rider.DrawPath(p, n, s, col, path) + END Draw; + + BEGIN + ASSERT(n >= 0, 20); ASSERT(n <= LEN(p), 21); + ASSERT((s # fill) OR (path = closedPoly) OR (path = closedBezier), 22); + ASSERT(s >= fill, 23); + Draw(p) + END DrawPath; + + PROCEDURE (f: Frame) MarkRect* (l, t, r, b, s: INTEGER; mode: INTEGER; show: BOOLEAN), NEW; + VAR u: INTEGER; + BEGIN + (* ASSERT((l <= r) & (t <= b), 20); *) ASSERT(s >= fill, 21); + u := f.unit; + l := (f.gx + l) DIV u; t := (f.gy + t) DIV u; + r := (f.gx + r) DIV u; b := (f.gy + b) DIV u; + s := s DIV u; + f.rider.MarkRect(l, t, r, b, s, mode, show) + END MarkRect; + + PROCEDURE (f: Frame) Scroll* (dx, dy: INTEGER), NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + ASSERT(dx MOD u = 0, 20); ASSERT(dy MOD u = 0, 20); + f.rider.Scroll(dx DIV u, dy DIV u) + END Scroll; + + PROCEDURE (f: Frame) SetCursor* (cursor: INTEGER), NEW; + BEGIN + f.rider.SetCursor(cursor) + END SetCursor; + + PROCEDURE (f: Frame) Input* (OUT x, y: INTEGER; OUT modifiers: SET; OUT isDown: BOOLEAN), NEW; + VAR u: INTEGER; + BEGIN + f.rider.Input(x, y, modifiers, isDown); + u := f.unit; + x := x * u - f.gx; y := y * u - f.gy + END Input; + + PROCEDURE (f: Frame) DrawString* (x, y: INTEGER; col: Color; IN s: ARRAY OF CHAR; + font: Fonts.Font), NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; y := (f.gy + y) DIV u; + f.rider.DrawString(x, y, col, s, font) + END DrawString; + + PROCEDURE (f: Frame) CharIndex* (x, pos: INTEGER; IN s: ARRAY OF CHAR; + font: Fonts.Font): INTEGER, NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; pos := (f.gx + pos) DIV u; + RETURN f.rider.CharIndex(x, pos, s, font) + END CharIndex; + + PROCEDURE (f: Frame) CharPos* (x, index: INTEGER; IN s: ARRAY OF CHAR; + font: Fonts.Font): INTEGER, NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; + RETURN f.rider.CharPos(x, index, s, font) * u - f.gx + END CharPos; + + PROCEDURE (f: Frame) DrawSString* (x, y: INTEGER; col: Color; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font), NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; y := (f.gy + y) DIV u; + f.rider.DrawSString(x, y, col, s, font) + END DrawSString; + + PROCEDURE (f: Frame) SCharIndex* (x, pos: INTEGER; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font): INTEGER, NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; pos := (f.gx + pos) DIV u; + RETURN f.rider.SCharIndex(x, pos, s, font) + END SCharIndex; + + PROCEDURE (f: Frame) SCharPos* (x, index: INTEGER; IN s: ARRAY OF SHORTCHAR; + font: Fonts.Font): INTEGER, NEW; + VAR u: INTEGER; + BEGIN + u := f.unit; + x := (f.gx + x) DIV u; + RETURN f.rider.SCharPos(x, index, s, font) * u - f.gx + END SCharPos; + + PROCEDURE RGBColor* (red, green, blue: INTEGER): Color; + BEGIN + ASSERT((red >= 0) & (red < 256), 20); + ASSERT((green >= 0) & (green < 256), 21); + ASSERT((blue >= 0) & (blue < 256), 22); + RETURN (blue * 65536) + (green * 256) + red + END RGBColor; + + PROCEDURE IsPrinterPort*(p: Port): BOOLEAN; + BEGIN + RETURN p.printerMode + END IsPrinterPort; + +BEGIN + background := white; dialogBackground := white +END Ports. diff --git a/Trurl-based/System/Mod/Printers.txt b/Trurl-based/System/Mod/Printers.txt new file mode 100644 index 0000000..e79e4ec --- /dev/null +++ b/Trurl-based/System/Mod/Printers.txt @@ -0,0 +1,63 @@ +MODULE Printers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Printers.odc *) + (* DO NOT EDIT *) + + IMPORT Ports; + + TYPE + Printer* = POINTER TO ABSTRACT RECORD + l, t, r, b: INTEGER; (** paper rect relative to port coords **) + res*: INTEGER; + port: Ports.Port + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + VAR dir-, stdDir-: Directory; + + + PROCEDURE (p: Printer) OpenJob* (VAR copies: INTEGER; name: ARRAY OF CHAR), NEW, ABSTRACT; + PROCEDURE (p: Printer) CloseJob* (), NEW, ABSTRACT; + PROCEDURE (p: Printer) OpenPage* (), NEW, ABSTRACT; + PROCEDURE (p: Printer) ClosePage* (), NEW, ABSTRACT; + + PROCEDURE (p: Printer) SetOrientation* (landscape: BOOLEAN), NEW, EMPTY; + + PROCEDURE (p: Printer) InitPort* (port: Ports.Port), NEW; + BEGIN + ASSERT((p.port = NIL) OR (p.port = port), 20); + p.port := port + END InitPort; + + PROCEDURE (p: Printer) ThisPort* (): Ports.Port, NEW; + BEGIN + RETURN p.port + END ThisPort; + + PROCEDURE (p: Printer) GetRect* (OUT l, t, r, b: INTEGER), NEW; + BEGIN + l := p.l; t := p.t; r:= p.r; b := p.b + END GetRect; + + PROCEDURE (p: Printer) InitPrinter* (l, t, r, b: INTEGER), NEW; + BEGIN + ASSERT(l <= r, 20); ASSERT(t <= b, 21); + p.l := l; p.t := t; p.r := r; p.b := b; + p.res := 0 + END InitPrinter; + + + PROCEDURE (d: Directory) Default* (): Printer, NEW, ABSTRACT; + PROCEDURE (d: Directory) Current* (): Printer, NEW, ABSTRACT; + PROCEDURE (d: Directory) Available* (): BOOLEAN, NEW, ABSTRACT; + + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d; + IF stdDir = NIL THEN stdDir := d END + END SetDir; + +END Printers. diff --git a/Trurl-based/System/Mod/Printing.txt b/Trurl-based/System/Mod/Printing.txt new file mode 100644 index 0000000..02555ab --- /dev/null +++ b/Trurl-based/System/Mod/Printing.txt @@ -0,0 +1,226 @@ +MODULE Printing; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Printing.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, Fonts, Ports, Dates, Printers, Views, Dialog, Strings; + + CONST maxNrOfSegments = 16; + + TYPE + PageInfo* = RECORD + first*, from*, to*: INTEGER; (** current IN **) + (** first, from, to: OUT, preset to (0, 0, 9999) **) + alternate*: BOOLEAN; + title*: Views.Title + END; + + Banner* = RECORD + font*: Fonts.Font; + gap*: INTEGER; (** OUT, prest to (0,0) **) + left*, right*: ARRAY 128 OF CHAR (** OUT, preset to "", "" **) + (** anywhere in header or footer: + &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 without path/title + **) + END; + + Par* = POINTER TO LIMITED RECORD + page*: PageInfo; + header*, footer*: Banner; + copies-: INTEGER + END; + + Line = RECORD + buf: ARRAY 256 OF CHAR; + beg: ARRAY maxNrOfSegments OF BYTE; + len: INTEGER + END; + + Hook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + VAR + par*: Par; + + month: ARRAY 12 * 3 + 1 OF CHAR; + printingHook: Hook; + + PROCEDURE (h: Hook) Print* (v: Views.View; par: Par), NEW, ABSTRACT; + PROCEDURE (h: Hook) Current* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE SetHook* (p: Hook); + BEGIN + printingHook := p + END SetHook; + + PROCEDURE NewPar* (IN page: PageInfo; IN header, footer: Banner; copies: INTEGER): Par; + VAR par: Par; + BEGIN + NEW(par); + par.page := page; + par.header := header; + par.footer := footer; + par.copies := copies; + IF par.header.font = NIL THEN par.header.font := Fonts.dir.Default() END; + IF par.footer.font = NIL THEN par.footer.font := Fonts.dir.Default() END; + RETURN par + END NewPar; + + PROCEDURE NewDefaultPar* (title: Views.Title): Par; + VAR par: Par; + BEGIN + NEW(par); + par.page.first := 1; + par.page.from := 0; + par.page.to := 9999; + par.page.alternate := FALSE; + par.copies := 1; + par.header.gap := 0; par.header.left := ""; par.header.right := ""; par.header.font := Fonts.dir.Default(); + par.footer.gap := 0; par.footer.left := ""; par.footer.right := ""; par.header.font := Fonts.dir.Default(); + par.page.title := title; + RETURN par + END NewDefaultPar; + + PROCEDURE PrintView* (view: Views.View; p: Par); + BEGIN + ASSERT(view # NIL, 20); ASSERT(p # NIL, 21); + ASSERT(par = NIL, 22); (* no recursive printing *) + IF Printers.dir.Available() THEN + ASSERT(p.page.first >= 0, 23); + ASSERT(p.page.from >= 0, 24); + ASSERT(p.page.to >= p.page.from, 25); + ASSERT(printingHook # NIL, 100); + printingHook.Print(view, p) + ELSE Dialog.ShowMsg("#System:NoPrinterFound") + END + END PrintView; + + PROCEDURE GetDateAndTime (IN date: Dates.Date; IN time: Dates.Time; + VAR d, t: ARRAY OF CHAR); + VAR i, j, k: INTEGER; s: ARRAY 8 OF CHAR; + BEGIN + Strings.IntToStringForm (date.day, Strings.decimal, 0, "0", FALSE, d); + + j := date.month * 3; i := j - 3; k := 0; + WHILE i < j DO s[k] := month[i]; INC(k); INC(i) END; s[k] := 0X; + d := d + "-" + s; + + Strings.IntToStringForm (date.year, Strings.decimal, 0, "0", FALSE, s); + d := d + "-" + s; + + Strings.IntToStringForm (time.hour, Strings.decimal, 0, "0", FALSE, t); + Strings.IntToStringForm (time.minute, Strings.decimal, 2, "0", FALSE, s); + t := t + ":" + s; + END GetDateAndTime; + + PROCEDURE Expand (s: ARRAY OF CHAR; IN date: Dates.Date; IN time: Dates.Time; + IN title: Views.Title; pno: INTEGER; printing: BOOLEAN; VAR line: Line); + VAR i, l: INTEGER; ch: CHAR; j: BYTE; + p, d, t, r, rl: ARRAY 32 OF CHAR; + BEGIN + IF printing THEN + Strings.IntToStringForm (pno, Strings.decimal, 0, "0", FALSE, p); + IF (0 < pno) & (pno < 4000) THEN + Strings.IntToStringForm(pno, Strings.roman, 0, " ", FALSE, r) + ELSE + r := p + END; + ELSE p := "#"; r := "#" + END; + + GetDateAndTime(date, time, d, t); + + i := 0; ch := s[i]; line.len := 0; j := 0; + WHILE ch # 0X DO + IF ch = "&" THEN + INC(i); ch := s[i]; + IF ch = "p" THEN + l := 0; WHILE p[l] # 0X DO line.buf[j] := p[l]; INC(j); INC(l) END + ELSIF ch = "r" THEN + Strings.ToLower(r, rl); + l := 0; WHILE rl[l] # 0X DO line.buf[j] := rl[l]; INC(j); INC(l) END + ELSIF ch = "R" THEN + l := 0; WHILE r[l] # 0X DO line.buf[j] := r[l]; INC(j); INC(l) END + ELSIF (ch = "a") OR (ch = "A") THEN + IF printing & (0 < pno) & (pno <= 26) THEN line.buf[j] := CHR(pno + ORD(ch) - 1); INC(j) + ELSE l := 0; WHILE p[l] # 0X DO line.buf[j] := p[l]; INC(j); INC(l) END + END + ELSIF ch = "d" THEN + l := 0; WHILE d[l] # 0X DO line.buf[j] := d[l]; INC(j); INC(l) END + ELSIF ch = "t" THEN + l := 0; WHILE t[l] # 0X DO line.buf[j] := t[l]; INC(j); INC(l) END + ELSIF ch = "f" THEN + l := 0; WHILE title[l] # 0X DO line.buf[j] := title[l]; INC(j); INC(l) END + ELSIF ch = ";" THEN + IF (line.len < maxNrOfSegments-1) THEN line.beg[line.len] := j; INC(line.len) + ELSE line.buf[j] := " "; INC(j) + END + ELSIF ch = "&" THEN + line.buf[j] := "&"; INC(j) + END; + IF ch # 0X THEN INC(i); ch := s[i] END + ELSE line.buf[j] := ch; INC(j); INC(i); ch := s[i] + END + END; + line.buf[j] := 0X; line.beg[line.len] := j; INC(line.len) + END Expand; + + PROCEDURE PrintLine (f: Views.Frame; font: Fonts.Font; + x0, x1, y: INTEGER; VAR line: Line); + VAR sp, dx, x: INTEGER; i, j, k: INTEGER; buf: ARRAY 128 OF CHAR; + BEGIN + sp := (x1 - x0 - font.StringWidth(line.buf)); + IF line.len = 1 THEN (* center *) + f.DrawString(x0 + sp DIV 2, y, Ports.defaultColor, line.buf, font) + ELSE + IF sp > 0 THEN dx := sp DIV (line.len - 1) ELSE dx := 0 END; + k := 0; j := 0; x := x0; + WHILE k < line.len DO + i := 0; + WHILE j < line.beg[k] DO + buf[i] := line.buf[j]; INC(i); INC(j) + END; + buf[i] := 0X; + f.DrawString(x, y, Ports.defaultColor, buf, font); + x := x + font.StringWidth(buf) + dx; + INC(k) + END + END + END PrintLine; + + PROCEDURE PrintBanner* (f: Views.Frame; IN p: PageInfo; IN b: Banner; + IN date: Dates.Date; IN time: Dates.Time; x0, x1, y: INTEGER); + VAR line: Line; printing: BOOLEAN; + BEGIN + printing := par # NIL; + IF printing THEN + ASSERT(printingHook # NIL, 100); + IF p.alternate & ~ODD(p.first + printingHook.Current()) THEN + Expand(b.left, date, time, p.title, p.first + printingHook.Current(), printing, line) + ELSE + Expand(b.right, date, time, p.title, p.first + printingHook.Current(), printing, line) + END + ELSE + Expand(b.right, date, time, p.title, 0, printing, line) + END; + PrintLine(f, b.font, x0, x1, y, line) + END PrintBanner; + + PROCEDURE Current*(): INTEGER; + BEGIN + ASSERT(par # NIL, 21); + ASSERT(printingHook # NIL, 100); + RETURN printingHook.Current() + END Current; + +BEGIN + month := "JanFebMarAprMayJunJulAugSepOctNovDec" +END Printing. diff --git a/Trurl-based/System/Mod/Properties.txt b/Trurl-based/System/Mod/Properties.txt new file mode 100644 index 0000000..d60479f --- /dev/null +++ b/Trurl-based/System/Mod/Properties.txt @@ -0,0 +1,425 @@ +MODULE Properties; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Properties.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel, Math, Services, Fonts, Stores, Views, Controllers, Dialog; + + CONST + (** StdProp.known/valid **) + color* = 0; typeface* = 1; size* = 2; style* = 3; weight* = 4; + + (** SizeProp.known/valid **) + width* = 0; height* = 1; + + (** PollVerbsMsg limitation **) + maxVerbs* = 16; + + (** PollPickMsg.mark, PollPick mark **) + noMark* = FALSE; mark* = TRUE; + (** PollPickMsg.show, PollPick show **) + hide* = FALSE; show* = TRUE; + + + TYPE + Property* = POINTER TO ABSTRACT RECORD + next-: Property; (** property lists are sorted **) (* by TD address *) + known*, readOnly*: SET; (** used for polling, ignored when setting properties **) + valid*: SET + END; + + StdProp* = POINTER TO RECORD (Property) + color*: Dialog.Color; + typeface*: Fonts.Typeface; + size*: INTEGER; + style*: RECORD val*, mask*: SET END; + weight*: INTEGER + END; + + SizeProp* = POINTER TO RECORD (Property) + width*, height*: INTEGER + END; + + + (** property messages **) + + Message* = Views.PropMessage; + + PollMsg* = RECORD (Message) + prop*: Property (** preset to NIL **) + END; + + SetMsg* = RECORD (Message) + old*, prop*: Property + END; + + + (** preferences **) + + Preference* = ABSTRACT RECORD (Message) END; + + ResizePref* = RECORD (Preference) + fixed*: BOOLEAN; (** OUT, preset to FALSE **) + horFitToPage*: BOOLEAN; (** OUT, preset to FALSE **) + verFitToPage*: BOOLEAN; (** OUT, preset to FALSE **) + horFitToWin*: BOOLEAN; (** OUT, preset to FALSE **) + verFitToWin*: BOOLEAN; (** OUT, preset to FALSE **) + END; + + SizePref* = RECORD (Preference) + w*, h*: INTEGER; (** OUT, preset to caller's preference **) + fixedW*, fixedH*: BOOLEAN (** IN **) + END; + + BoundsPref* = RECORD (Preference) + w*, h*: INTEGER (** OUT, preset to (Views.undefined, Views.undefined) **) + END; + + FocusPref* = RECORD (Preference) + atLocation*: BOOLEAN; (** IN **) + x*, y*: INTEGER; (** IN, valid iff atLocation **) + hotFocus*, setFocus*: BOOLEAN (** OUT, preset to (FALSE, FALSE) **) + END; + + ControlPref* = RECORD (Preference) + char*: CHAR; (** IN **) + focus*: Views.View; (** IN **) + getFocus*: BOOLEAN; (** OUT, valid if (v # focus), preset to ((char = [l]tab) & "FocusPref.setFocus") **) + accepts*: BOOLEAN (** OUT, preset to ((v = focus) & (char # [l]tab)) **) + END; + + TypePref* = RECORD (Preference) + type*: Stores.TypeName; (** IN **) + view*: Views.View (** OUT, preset to NIL **) + END; + + + (** verbs **) + + PollVerbMsg* = RECORD (Message) + verb*: INTEGER; (** IN **) + label*: ARRAY 64 OF CHAR; (** OUT, preset to "" **) + disabled*, checked*: BOOLEAN (** OUT, preset to FALSE, FALSE **) + END; + + DoVerbMsg* = RECORD (Message) + verb*: INTEGER; (** IN **) + frame*: Views.Frame (** IN **) + END; + + + (** controller messages **) + + CollectMsg* = RECORD (Controllers.Message) + poll*: PollMsg (** OUT, preset to NIL **) + END; + + EmitMsg* = RECORD (Controllers.RequestMessage) + set*: SetMsg (** IN **) + END; + + + PollPickMsg* = RECORD (Controllers.TransferMessage) + mark*: BOOLEAN; (** IN, request to mark pick target **) + show*: BOOLEAN; (** IN, if mark then show/hide target mark **) + dest*: Views.Frame (** OUT, preset to NIL, set if PickMsg is acceptable **) + END; + + PickMsg* = RECORD (Controllers.TransferMessage) + prop*: Property (** set to picked properties by destination **) + END; + + + VAR era-: INTEGER; (* estimator to cache standard properties of focus *) + + + PROCEDURE ^ IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN); + + + (** properties **) + + PROCEDURE (p: Property) IntersectWith* (q: Property; OUT equal: BOOLEAN), NEW, ABSTRACT; + + PROCEDURE (p: StdProp) IntersectWith* (q: Property; OUT equal: BOOLEAN); + VAR valid: SET; c, m: SET; eq: BOOLEAN; + BEGIN + WITH q: StdProp DO + valid := p.valid * q.valid; equal := TRUE; + IF p.color.val # q.color.val THEN EXCL(valid, color) END; + IF p.typeface # q.typeface THEN EXCL(valid, typeface) END; + IF p.size # q.size THEN EXCL(valid, size) END; + IntersectSelections(p.style.val, p.style.mask, q.style.val, q.style.mask, c, m, eq); + IF m = {} THEN EXCL(valid, style) + ELSIF (style IN valid) & ~eq THEN p.style.mask := m; equal := FALSE + END; + IF p.weight # q.weight THEN EXCL(valid, weight) END; + IF p.valid # valid THEN p.valid := valid; equal := FALSE END + END + END IntersectWith; + + PROCEDURE (p: SizeProp) IntersectWith* (q: Property; OUT equal: BOOLEAN); + VAR valid: SET; + BEGIN + WITH q: SizeProp DO + valid := p.valid * q.valid; equal := TRUE; + IF p.width # q.width THEN EXCL(valid, width) END; + IF p.height # q.height THEN EXCL(valid, height) END; + IF p.valid # valid THEN p.valid := valid; equal := FALSE END + END + END IntersectWith; + + + (** property collection and emission **) + + PROCEDURE IncEra*; + BEGIN + INC(era) + END IncEra; + + + PROCEDURE CollectProp* (OUT prop: Property); + VAR msg: CollectMsg; + BEGIN + msg.poll.prop := NIL; + Controllers.Forward(msg); + prop := msg.poll.prop + END CollectProp; + + PROCEDURE CollectStdProp* (OUT prop: StdProp); + (** post: prop # NIL, prop.style.val = prop.style.val * prop.style.mask **) + VAR p: Property; + BEGIN + CollectProp(p); + WHILE (p # NIL) & ~(p IS StdProp) DO p := p.next END; + IF p # NIL THEN + prop := p(StdProp); prop.next := NIL + ELSE + NEW(prop); prop.known := {} + END; + prop.valid := prop.valid * prop.known; + prop.style.val := prop.style.val * prop.style.mask + END CollectStdProp; + + PROCEDURE EmitProp* (old, prop: Property); + VAR msg: EmitMsg; + BEGIN + IF prop # NIL THEN + msg.set.old := old; msg.set.prop := prop; + Controllers.Forward(msg) + END + END EmitProp; + + + PROCEDURE PollPick* (x, y: INTEGER; + source: Views.Frame; sourceX, sourceY: INTEGER; + mark, show: BOOLEAN; + OUT dest: Views.Frame; OUT destX, destY: INTEGER); + VAR msg: PollPickMsg; + BEGIN + ASSERT(source # NIL, 20); + msg.mark := mark; msg.show := show; msg.dest := NIL; + Controllers.Transfer(x, y, source, sourceX, sourceY, msg); + dest := msg.dest; destX := msg.x; destY := msg.y + END PollPick; + + PROCEDURE Pick* (x, y: INTEGER; source: Views.Frame; sourceX, sourceY: INTEGER; + OUT prop: Property); + VAR msg: PickMsg; + BEGIN + ASSERT(source # NIL, 20); + msg.prop := NIL; + Controllers.Transfer(x, y, source, sourceX, sourceY, msg); + prop := msg.prop + END Pick; + + + (** property list construction **) + + PROCEDURE Insert* (VAR list: Property; x: Property); + VAR p, q: Property; ta: INTEGER; + BEGIN + ASSERT(x # NIL, 20); ASSERT(x.next = NIL, 21); ASSERT(x # list, 22); + ASSERT(x.valid - x.known = {}, 23); + IF list # NIL THEN + ASSERT(list.valid - list.known = {}, 24); + ASSERT(Services.TypeLevel(list) = 1, 25) + END; + ta := SYSTEM.TYP(x^); + ASSERT(Services.TypeLevel(x) = 1, 26); + p := list; q := NIL; + WHILE (p # NIL) & (SYSTEM.TYP(p^) < ta) DO + q := p; p := p.next + END; + IF (p # NIL) & (SYSTEM.TYP(p^) = ta) THEN x.next := p.next ELSE x.next := p END; + IF q # NIL THEN q.next := x ELSE list := x END + END Insert; + + PROCEDURE CopyOfList* (p: Property): Property; + VAR q, r, s: Property; t: Kernel.Type; + BEGIN + q := NIL; s := NIL; + WHILE p # NIL DO + ASSERT(Services.TypeLevel(p) = 1, 20); + t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23); + SYSTEM.MOVE(p, r, t.size); + r.next := NIL; + IF q # NIL THEN q.next := r ELSE s := r END; + q := r; p := p.next + END; + RETURN s + END CopyOfList; + + PROCEDURE CopyOf* (p: Property): Property; + VAR r: Property; t: Kernel.Type; + BEGIN + IF p # NIL THEN + ASSERT(Services.TypeLevel(p) = 1, 20); + t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23); + SYSTEM.MOVE(p, r, t.size); + r.next := NIL; + END; + RETURN r + END CopyOf; + + PROCEDURE Merge* (VAR base, override: Property); + VAR p, q, r, s: Property; tp, tr: INTEGER; + BEGIN + ASSERT((base # override) OR (base = NIL), 20); + p := base; q := NIL; r := override; override := NIL; + IF p # NIL THEN + tp := SYSTEM.TYP(p^); + ASSERT(Services.TypeLevel(p) = 1, 21) + END; + IF r # NIL THEN + tr := SYSTEM.TYP(r^); + ASSERT(Services.TypeLevel(r) = 1, 22) + END; + WHILE (p # NIL) & (r # NIL) DO + ASSERT(p # r, 23); + WHILE (p # NIL) & (tp < tr) DO + q := p; p := p.next; + IF p # NIL THEN tp := SYSTEM.TYP(p^) END + END; + IF p # NIL THEN + IF tp = tr THEN + s := p.next; p.next := NIL; p := s; + IF p # NIL THEN tp := SYSTEM.TYP(p^) END + ELSE + END; + s := r.next; + IF q # NIL THEN q.next := r ELSE base := r END; + q := r; r.next := p; r := s; + IF r # NIL THEN tr := SYSTEM.TYP(r^) END + END + END; + IF r # NIL THEN + IF q # NIL THEN q.next := r ELSE base := r END + END + END Merge; + + PROCEDURE Intersect* (VAR list: Property; x: Property; OUT equal: BOOLEAN); + VAR l, p, q, r, s: Property; plen, rlen, ta: INTEGER; filtered: BOOLEAN; + BEGIN + ASSERT((x # list) OR (list = NIL), 20); + IF list # NIL THEN ASSERT(Services.TypeLevel(list) = 1, 21) END; + IF x # NIL THEN ASSERT(Services.TypeLevel(x) = 1, 22) END; + p := list; s := NIL; list := NIL; l := NIL; plen := 0; + r := x; rlen := 0; filtered := FALSE; + WHILE (p # NIL) & (r # NIL) DO + q := p.next; p.next := NIL; INC(plen); + ta := SYSTEM.TYP(p^); + WHILE (r # NIL) & (SYSTEM.TYP(r^) < ta) DO + r := r.next; INC(rlen) + END; + IF (r # NIL) & (SYSTEM.TYP(r^) = ta) THEN + ASSERT(r # p, 23); + IF l # NIL THEN s.next := p ELSE l := p END; + s := p; + p.known := p.known + r.known; + p.IntersectWith(r, equal); + filtered := filtered OR ~equal OR (p.valid # r.valid); + r := r.next; INC(rlen) + END; + p := q + END; + list := l; + equal := (p = NIL) & (r = NIL) & (plen = rlen) & ~filtered + END Intersect; + + + (** support for IntersectWith methods **) + + PROCEDURE IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN); + BEGIN + cMask := aMask * bMask - (a / b); + c := a * cMask; + equal := (aMask = bMask) & (bMask = cMask) + END IntersectSelections; + + + (** standard preferences protocols **) + + PROCEDURE PreferredSize* (v: Views.View; minW, maxW, minH, maxH, defW, defH: INTEGER; + VAR w, h: INTEGER); + VAR p: SizePref; + BEGIN + ASSERT(Views.undefined < minW, 20); ASSERT(minW < maxW, 21); + ASSERT(Views.undefined < minH, 23); ASSERT(minH < maxH, 24); + ASSERT(Views.undefined <= defW, 26); + ASSERT(Views.undefined <= defH, 28); + IF (w < Views.undefined) OR (w > maxW) THEN w := defW END; + IF (h < Views.undefined) OR (h > maxH) THEN h := defH END; + p.w := w; p.h := h; p.fixedW := FALSE; p.fixedH := FALSE; + Views.HandlePropMsg(v, p); w := p.w; h := p.h; + IF w = Views.undefined THEN w := defW END; + IF h = Views.undefined THEN h := defH END; + IF w < minW THEN w := minW ELSIF w > maxW THEN w := maxW END; + IF h < minH THEN h := minH ELSIF h > maxH THEN h := maxH END + END PreferredSize; + + + (** common resizing constraints **) + + PROCEDURE ProportionalConstraint* (scaleW, scaleH: INTEGER; fixedW, fixedH: BOOLEAN; VAR w, h: INTEGER); + (** pre: w > Views.undefined, h > Views.undefined **) + (** post: (E s: s * scaleW = w, s * scaleH = h), |w * h - w' * h'| min! **) + VAR area: REAL; + BEGIN + ASSERT(scaleW > Views.undefined, 22); ASSERT(scaleH > Views.undefined, 23); + IF fixedH THEN + ASSERT(~fixedW, 24); + ASSERT(h > Views.undefined, 21); + area := h; area := area * scaleW; + w := SHORT(ENTIER(area / scaleH)) + ELSIF fixedW THEN + ASSERT(w > Views.undefined, 20); + area := w; area := area * scaleH; + h := SHORT(ENTIER(area / scaleW)) + ELSE + ASSERT(w > Views.undefined, 20); ASSERT(h > Views.undefined, 21); + area := w; area := area * h; + w := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleW / scaleH))); + h := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleH / scaleW))) + END + END ProportionalConstraint; + + PROCEDURE GridConstraint* (gridX, gridY: INTEGER; VAR x, y: INTEGER); + VAR dx, dy: INTEGER; + BEGIN + ASSERT(gridX > Views.undefined, 20); + ASSERT(gridY > Views.undefined, 21); + dx := x MOD gridX; + IF dx < gridX DIV 2 THEN DEC(x, dx) ELSE INC(x, (-x) MOD gridX) END; + dy := y MOD gridY; + IF dy < gridY DIV 2 THEN DEC(y, dy) ELSE INC(y, (-y) MOD gridY) END + END GridConstraint; + + PROCEDURE ThisType* (view: Views.View; type: Stores.TypeName): Views.View; + VAR msg: TypePref; + BEGIN + msg.type := type; msg.view := NIL; + Views.HandlePropMsg(view, msg); + RETURN msg.view + END ThisType; + +END Properties. diff --git a/Trurl-based/System/Mod/SMath.txt b/Trurl-based/System/Mod/SMath.txt new file mode 100644 index 0000000..a512f83 --- /dev/null +++ b/Trurl-based/System/Mod/SMath.txt @@ -0,0 +1,392 @@ +MODULE SMath; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/SMatch.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM; + + VAR eps, e: SHORTREAL; + + + (* code procedures for 80387 math coprocessor *) + + PROCEDURE [code] FLD (x: SHORTREAL); + PROCEDURE [code] TOP (): SHORTREAL; + PROCEDURE [code] FSW (): INTEGER 0DFH, 0E0H; + PROCEDURE [code] FSWs (): SET 0DFH, 0E0H; + PROCEDURE [code] ST0 (): SHORTREAL 0D9H, 0C0H; + PROCEDURE [code] ST1 (): SHORTREAL 0D9H, 0C1H; + + PROCEDURE [code] FXCH 0D9H, 0C9H; + PROCEDURE [code] FLDst0 0D9H, 0C0H; (* doublicate st[0] *) + PROCEDURE [code] FSTPst0 0DDH, 0D8H; (* remove st[0] *) + PROCEDURE [code] FSTPst1 0DDH, 0D9H; (* remove st[1] *) + PROCEDURE [code] FSTPDe 0DBH, 05DH, 0F4H; (* FSTPD -12[FP] *) (* COMPILER DEPENDENT *) + PROCEDURE [code] WAIT 09BH; + PROCEDURE [code] FNOP 0D9H, 0D0H; + + PROCEDURE [code] FLD0 0D9H, 0EEH; + PROCEDURE [code] FLD1 0D9H, 0E8H; + PROCEDURE [code] FLDPI 0D9H, 0EBH; + PROCEDURE [code] FLDLN2 0D9H, 0EDH; + PROCEDURE [code] FLDLG2 0D9H, 0ECH; + PROCEDURE [code] FLDL2E 0D9H, 0EAH; + + PROCEDURE [code] FADD 0DEH, 0C1H; + PROCEDURE [code] FADDst0 0D8H, 0C0H; + PROCEDURE [code] FSUB 0DEH, 0E9H; + PROCEDURE [code] FSUBn 0DCH, 0E9H; (* no pop *) + PROCEDURE [code] FSUBR 0DEH, 0E1H; + PROCEDURE [code] FSUBst1 0D8H, 0E1H; + PROCEDURE [code] FMUL 0DEH, 0C9H; + PROCEDURE [code] FMULst0 0D8H, 0C8H; + PROCEDURE [code] FMULst1st0 0DCH, 0C9H; + PROCEDURE [code] FDIV 0DEH, 0F9H; + PROCEDURE [code] FDIVR 0DEH, 0F1H; + PROCEDURE [code] FDIVRst1 0D8H, 0F9H; + PROCEDURE [code] FCHS 0D9H, 0E0H; + + PROCEDURE [code] FCOM 0D8H, 0D1H; + PROCEDURE [code] FSWax 0DFH, 0E0H; + PROCEDURE [code] SAHF 09EH; + PROCEDURE [code] JBE4 076H, 004H; + PROCEDURE [code] JAE4 073H, 004H; + + PROCEDURE [code] FRNDINT 0D9H, 0FCH; + PROCEDURE [code] FSCALE 0D9H, 0FDH; (* st[0] * 2^FLOOR(st[1]) *) + PROCEDURE [code] FXTRACT 0D9H, 0F4H; (* exp -> st[1]; mant -> st[0] *) + PROCEDURE [code] FXAM 0D9H, 0E5H; + + PROCEDURE [code] FSQRT 0D9H, 0FAH; (* st[0] >= 0 *) + PROCEDURE [code] FSIN 0D9H, 0FEH; (* |st[0]| < 2^63 *) + PROCEDURE [code] FCOS 0D9H, 0FFH; (* |st[0]| < 2^63 *) + PROCEDURE [code] FTAN 0D9H, 0F2H; (* |st[0]| < 2^63 *) + PROCEDURE [code] FATAN 0D9H, 0F3H; (* atan2(st[1], st[0]) *) + PROCEDURE [code] FYL2X 0D9H, 0F1H; (* st[1] * log2(st[0]), st[0] > 0 *) + PROCEDURE [code] FYL2XP1 0D9H, 0F9H; (* st[1] * log2(1 + st[0]), |st[0]| < 1-sqrt(2)/2 *) + PROCEDURE [code] F2XM1 0D9H, 0F0H; (* 2^st[0] - 1, |st[0]| <= 1 *) + + + PROCEDURE IsNan (x: SHORTREAL): BOOLEAN; + BEGIN + FLD(x); FXAM; FSTPst0; WAIT; RETURN FSWs() * {8, 10} = {8} + END IsNan; + + + (* sin, cos, tan argument reduction *) + + PROCEDURE Reduce; + BEGIN + FXAM; WAIT; + IF ~(8 IN FSWs()) & (ABS(ST0()) > 1.0E18) THEN + (* to be completed *) + FSTPst0; FLD0 + END; + END Reduce; + + + (** SHORTREAL precision **) + + PROCEDURE Pi* (): SHORTREAL; + BEGIN + FLDPI; RETURN TOP() + END Pi; + + PROCEDURE Eps* (): SHORTREAL; + BEGIN + RETURN eps + END Eps; + + + PROCEDURE Sqrt* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, argument of Sqrt must not be negative *) + FLD(x); FSQRT; WAIT; RETURN TOP() + END Sqrt; + + + PROCEDURE Exp* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 2 ^ (x * 1/ln(2)) *) + FLD(x); FLDL2E; FMUL; + IF ABS(ST0()) = INF THEN FLD1 + ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD + END; + FSCALE; FSTPst1; RETURN TOP() + END Exp; + + PROCEDURE Ln* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, argument of Ln must not be negative *) + (* ln(2) * ld(x) *) + FLDLN2; FLD(x); FYL2X; WAIT; RETURN TOP() + END Ln; + + PROCEDURE Log* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, argument of Log must not be negative *) + (* log(2) * ld(x) *) + FLDLG2; FLD(x); FYL2X; WAIT; RETURN TOP() + END Log; + + PROCEDURE Power* (x, y: SHORTREAL): SHORTREAL; + BEGIN + ASSERT(x >= 0, 20); + ASSERT((x # 0.0) OR (y # 0.0), 21); + ASSERT((x # INF) OR (y # 0.0), 22); + ASSERT((x # 1.0) OR (ABS(y) # INF), 23); + (* 2 ^ (y * ld(x)) *) + FLD(y); FLD(x); FYL2X; + IF ABS(ST0()) = INF THEN FLD1 + ELSE FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD + END; + FSCALE; FSTPst1; WAIT; RETURN TOP() + END Power; + + PROCEDURE IntPower* (x: SHORTREAL; n: INTEGER): SHORTREAL; + BEGIN + FLD1; FLD(x); + IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END; + IF n <= 0 THEN FDIVRst1; (* 1 / x *) n := -n END; + WHILE n > 0 DO + IF ODD(n) THEN FMULst1st0; (* y := y * x *) DEC(n) + ELSE FMULst0; (* x := x * x *) n := n DIV 2 + END + END; + FSTPst0; RETURN TOP() + END IntPower; + + + PROCEDURE Sin* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FSIN; WAIT; RETURN TOP() + END Sin; + + PROCEDURE Cos* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FCOS; WAIT; RETURN TOP() + END Cos; + + PROCEDURE Tan* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, ABS(x) # INF *) + FLD(x); Reduce; FTAN; FSTPst0; WAIT; RETURN TOP() + END Tan; + + PROCEDURE ArcSin* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* atan2(x, sqrt(1 - x*x)) *) + FLD(x); FLDst0; FMULst0; FLD1; FSUBR; FSQRT; FNOP; FATAN; WAIT; RETURN TOP() + END ArcSin; + + PROCEDURE ArcCos* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* atan2(sqrt(1 - x*x), x) *) + FLD(x); FMULst0; FLD1; FSUBR; FSQRT; FLD(x); FATAN; WAIT; RETURN TOP() + END ArcCos; + + PROCEDURE ArcTan* (x: SHORTREAL): SHORTREAL; + BEGIN + (* atan2(x, 1) *) + FLD(x); FLD1; FATAN; RETURN TOP() + END ArcTan; + + PROCEDURE ArcTan2* (y, x: SHORTREAL): SHORTREAL; + BEGIN + ASSERT((y # 0) OR (x # 0), 20); + ASSERT((ABS(y) # INF) OR (ABS(x) # INF), 21); + FLD(y); FLD(x); FATAN; WAIT; RETURN TOP() + END ArcTan2; + + + PROCEDURE Sinh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* abs(x) * 1/ln(2) *) + FLD(ABS(x)); FLDL2E; FMUL; + IF ST0() < 0.5 THEN + (* (2^z - 1) + (2^z - 1) / ((2^z - 1) + 1) *) + F2XM1; FLDst0; FLDst0; FLD1; FADD; FDIV; FADD + ELSIF ST0() # INF THEN + (* 2^z - 1 / 2^z *) + FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; + FSTPst1; FLDst0; FLD1; FDIVR; FSUB + END; + IF x < 0 THEN FCHS END; + RETURN TOP() * 0.5 + END Sinh; + + PROCEDURE Cosh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* 2^(abs(x) * 1/ln(2)) *) + FLD(ABS(x)); + IF ST0() # INF THEN + FLDL2E; FMUL; FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; + FSTPst1; + (* z + 1/z *) + FLDst0; FLD1; FDIVR; FADD + END; + RETURN TOP() * 0.5 + END Cosh; + + PROCEDURE Tanh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* abs(x) * 1/ln(2) * 2 *) + FLD(ABS(x)); FLDL2E; FMUL; FADDst0; + IF ST0() < 0.5 THEN + (* (2^z - 1) / (2^z + 1) *) + F2XM1; FLDst0; FLD(2); FADD; FDIV + ELSIF ST0() < 65 THEN + (* 1 - 2 / (2^z + 1) *) + FLDst0; FRNDINT; FXCH; FSUBst1; FNOP; F2XM1; FLD1; FADD; FSCALE; FSTPst1; FLD1; FADD; FLD(2); FDIVR; FLD1; FSUBR + ELSE + FSTPst0; FLD1 + END; + IF x < 0 THEN FCHS END; + RETURN TOP() + END Tanh; + + PROCEDURE ArcSinh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* IF IsNan(x) THEN RETURN x END; *) + (* x*x *) + FLDLN2; FLD(ABS(x)); FLDst0; FMULst0; + IF ST0() < 0.067 THEN + (* ln(2) * ld(1 + x*x / (sqrt(x*x + 1) + 1) + x) *) + FLDst0; FLD1; FADD; FSQRT; FLD1; FADD; FDIV; FADD; FYL2XP1 + ELSE + (* ln(2) * ld(x + sqrt(x*x + 1)) *) + FLD1; FADD; FSQRT; FADD; FYL2X + END; + IF x < 0 THEN FCHS END; + RETURN TOP() + END ArcSinh; + + PROCEDURE ArcCosh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, x >= 1.0 *) + (* IF IsNan(x) THEN RETURN x END; *) + (* ln(2) * ld(x + sqrt(x*x - 1)) *) + FLDLN2; FLD(x); FLDst0; FMULst0; FLD1; FSUB; FSQRT; FADD; FYL2X; WAIT; RETURN TOP() + END ArcCosh; + + PROCEDURE ArcTanh* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, -1.0 <= x <= 1.0 *) + (* IF IsNan(x) THEN RETURN x END; *) + (* |x| *) + FLDLN2; FLD(ABS(x)); + IF ST0() < 0.12 THEN + (* ln(2) * ld(1 + 2*x / (1 - x)) *) + FLDst0; FLD1; FSUBR; FDIV; FADDst0; FYL2XP1 + ELSE + (* ln(2) * ld((1 + x) / (1 - x)) *) + FLDst0; FLD1; FADD; FXCH; FLD1; FSUBR; FDIV; FNOP; FYL2X + END; + IF x < 0 THEN FCHS END; + WAIT; + RETURN TOP() * 0.5 + END ArcTanh; + + + PROCEDURE Floor* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB; RETURN TOP() + END Floor; + + PROCEDURE Ceiling* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); FLDst0; FRNDINT; FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD; RETURN TOP() + END Ceiling; + + PROCEDURE Round* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); + IF ABS(ST0()) = INF THEN RETURN TOP() END; + FLDst0; FRNDINT; FSUBn; FXCH; + IF TOP() = 0.5 THEN FLD1; FADD END; + RETURN TOP() + END Round; + + PROCEDURE Trunc* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); FLDst0; FRNDINT; + IF ST1() >= 0 THEN + FCOM; FSWax; FSTPst1; SAHF; JBE4; FLD1; FSUB + ELSE + FCOM; FSWax; FSTPst1; SAHF; JAE4; FLD1; FADD + END; + RETURN TOP() + END Trunc; + + PROCEDURE Frac* (x: SHORTREAL): SHORTREAL; + BEGIN + (* 20, x # INF & x # -INF *) + FLD(x); FLDst0; FRNDINT; + IF ST1() >= 0 THEN + FCOM; FSWax; SAHF; JBE4; FLD1; FSUB + ELSE + FCOM; FSWax; SAHF; JAE4; FLD1; FADD + END; + FSUB; WAIT; RETURN TOP() + END Frac; + + + PROCEDURE Sign* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 0, 2: FSTPst0; RETURN 0.0 + | 1, 4, 5: FSTPst0; RETURN 1.0 + | 3, 6, 7: FSTPst0; RETURN -1.0 + END + END Sign; + + PROCEDURE Mantissa* (x: SHORTREAL): SHORTREAL; + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 4, 6: FXTRACT; FSTPst1; RETURN TOP() + | 0, 2: FSTPst0; RETURN 0.0 (* zero *) + | 5: FSTPst0; RETURN 1.0 (* inf *) + | 7: FSTPst0; RETURN -1.0 (* -inf *) + | 1: FSTPst0; RETURN 1.5 (* nan *) + | 3: FSTPst0; RETURN -1.5 (* -nan *) + END + END Mantissa; + + PROCEDURE Exponent* (x: SHORTREAL): INTEGER; (* COMPILER DEPENDENT *) + VAR e: INTEGER; (* e is set by FSTPDe! *) + BEGIN + FLD(x); FXAM; WAIT; + CASE FSW() DIV 256 MOD 8 OF + | 4, 6: FXTRACT; FSTPst0; FSTPDe; WAIT; RETURN e + | 0, 2: FSTPst0; RETURN 0 (* zero *) + | 1, 3, 5, 7: FSTPst0; RETURN MAX(INTEGER) (* inf or nan*) + END + END Exponent; + + PROCEDURE Real* (m: SHORTREAL; e: INTEGER): SHORTREAL; + VAR s: SET; + BEGIN + IF (m = 0) THEN RETURN 0.0 END; + ASSERT(~IsNan(m) & (1 <= ABS(m)) & (ABS(m) < 2), 20); + IF e = MAX(INTEGER) THEN + SYSTEM.GET(SYSTEM.ADR(m) + 4, s); + SYSTEM.PUT(SYSTEM.ADR(m) + 4, s + {20..30}); + RETURN m + ELSE + FLD(e); FLD(m); FSCALE; FSTPst1; RETURN TOP() + END + END Real; + +BEGIN + eps := 1.0E+0; e := 2.0E+0; + WHILE e > 1.0E+0 DO eps := eps/2.0E+0; e := 1.0E+0 + eps END; eps := 2.0E+0 * eps; +END SMath. diff --git a/Trurl-based/System/Mod/Sequencers.txt b/Trurl-based/System/Mod/Sequencers.txt new file mode 100644 index 0000000..fe2e1c3 --- /dev/null +++ b/Trurl-based/System/Mod/Sequencers.txt @@ -0,0 +1,86 @@ +MODULE Sequencers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Sequencers.odc *) + (* DO NOT EDIT *) + + IMPORT Stores; + + CONST + clean* = 0; + notUndoable* = 1; + invisible* = 2; + + TYPE + Message* = ABSTRACT RECORD END; + + Notifier* = POINTER TO ABSTRACT RECORD + next: Notifier + END; + + Sequencer* = POINTER TO ABSTRACT RECORD + notifiers: Notifier + END; + + CloseMsg* = RECORD (Message) + sticky*: BOOLEAN (** OUT, preset to FALSE **) + END; + + RemoveMsg* = RECORD (Message) END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + VAR dir*: Directory; + + (** Directory **) + PROCEDURE (dir: Directory) New* (): Sequencer, NEW, ABSTRACT; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); dir := d + END SetDir; + + + (** Notifier **) + + PROCEDURE (f: Notifier) Notify* (VAR msg: Message), NEW, EMPTY; + + + (** Sequencer **) + + PROCEDURE (s: Sequencer) Dirty* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (s: Sequencer) SetDirty* (dirty: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) BeginScript* (IN name: Stores.OpName; + VAR script: Stores.Operation), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) Do* (st: Stores.Store; IN name: Stores.OpName; + op: Stores.Operation), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) LastOp* (st: Stores.Store): Stores.Operation, NEW, ABSTRACT; + PROCEDURE (s: Sequencer) Bunch* (st: Stores.Store), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) EndScript* (script: Stores.Operation), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) StopBunching* (), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) BeginModification* (type: INTEGER; st: Stores.Store), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) EndModification* (type: INTEGER; st: Stores.Store), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) CanUndo* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (s: Sequencer) CanRedo* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (s: Sequencer) GetUndoName* (VAR name: Stores.OpName), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) GetRedoName* (VAR name: Stores.OpName), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) Undo* (), NEW, ABSTRACT; + PROCEDURE (s: Sequencer) Redo* (), NEW, ABSTRACT; + + PROCEDURE (s: Sequencer) Handle* (VAR msg: ANYREC), NEW, EMPTY; + + PROCEDURE (s: Sequencer) Notify* (VAR msg: Message), NEW; + VAR n: Notifier; + BEGIN + n := s.notifiers; + WHILE n # NIL DO + n.Notify(msg); + n := n.next + END + END Notify; + + PROCEDURE (s: Sequencer) InstallNotifier* (n: Notifier), NEW; + BEGIN + n.next := s.notifiers; s.notifiers := n + END InstallNotifier; + +END Sequencers. diff --git a/Trurl-based/System/Mod/Services.txt b/Trurl-based/System/Mod/Services.txt new file mode 100644 index 0000000..6ad9cae --- /dev/null +++ b/Trurl-based/System/Mod/Services.txt @@ -0,0 +1,256 @@ +MODULE Services; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Services.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel; + + CONST + now* = 0; immediately* = -1; (** DoLater notBefore **) + resolution* = 1000; + scale = resolution DIV Kernel.timeResolution; + corr = resolution MOD Kernel.timeResolution; + + + TYPE + Action* = POINTER TO ABSTRACT RECORD + notBefore: LONGINT; + next: Action (* next element in linear list *) + END; + + ActionHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + StdHook = POINTER TO RECORD (ActionHook) END; + + + VAR + actionHook-: ActionHook; + actions: Action; (* list of actions *) + candidates: Action; (* list of action candidates in IterateOverActions, + NIL during normal execution of commands *) + hasImmediates: BOOLEAN; (* this is a hint: one or more actions in some ring may be immediate actions *) + trapCnt: INTEGER; + + + PROCEDURE Ticks* (): LONGINT; + VAR t: LONGINT; + BEGIN + t := Kernel.Time(); + RETURN t * scale + t * corr DIV Kernel.timeResolution + END Ticks; + + + (** Action **) + + PROCEDURE (a: Action) Do- (), NEW, ABSTRACT; + + PROCEDURE In (l, a: Action): BOOLEAN; + BEGIN + WHILE (l # NIL) & (l # a) DO l := l.next END; + RETURN l # NIL + END In; + + PROCEDURE Incl (VAR l: Action; a: Action); + BEGIN + IF l # NIL THEN a.next := l END; + l := a + END Incl; + + PROCEDURE Excl (VAR l: Action; a: Action); + VAR p0, p1: Action; + BEGIN + IF l = a THEN + l := a.next; a.next := NIL + ELSIF l # NIL THEN + p0 := l; p1 := p0.next; + (* (p0 # NIL) & (p0 # a) *) + WHILE (p1 # NIL) & (p1 # a) DO p0 := p1; p1 := p0.next END; + IF p1 = a THEN p0.next := a.next; a.next := NIL END + END + END Excl; + + PROCEDURE Exec (a: Action); + VAR t: Kernel.Type; + BEGIN + t := Kernel.TypeOf(a); + IF t.mod.refcnt >= 0 THEN (* execute action if its module is not unloaded *) + a.Do (* warning: here the actions and candidates lists may be modified, or a trap may occur! *) + END + END Exec; + + PROCEDURE Cleanup; + VAR p: Action; + BEGIN + IF candidates # NIL THEN (* trap handling *) + p := candidates; WHILE p.next # NIL DO p := p.next END; (* find last element of candidates list *) + p.next := actions; actions := candidates; candidates := NIL (* prepend candidates list to actions list *) + END; + trapCnt := Kernel.trapCount (* all traps are handled now *) + END Cleanup; + + PROCEDURE DoLater* (a: Action; notBefore: LONGINT); + (** Register action a. If a is already registered, its notBefore value is updated instead. **) + BEGIN + ASSERT(a # NIL, 20); + IF ~In(actions, a) & ~In(candidates, a) THEN + Incl(actions, a) + END; + a.notBefore := notBefore; (* if a was already in a list, this statement updates the notBefore value *) + IF notBefore = immediately THEN hasImmediates := TRUE END + END DoLater; + + PROCEDURE RemoveAction* (a: Action); + (** Unregister action a. If a is not registered, nothing happens **) + BEGIN + IF a # NIL THEN + Excl(actions, a); + Excl(candidates, a) + END + END RemoveAction; + + PROCEDURE IterateOverActions (time: LONGINT); + VAR p: Action; + BEGIN + Cleanup; (* trap handling, if necessary *) + (* candidates = NIL *) + candidates := actions; actions := NIL; (* move action list to candidates list *) + WHILE candidates # NIL DO (* for every candidate: execute it or put it back into actions list *) + p := candidates; candidates := p.next; (* remove head element from candidates list *) + IF (0 <= p.notBefore) & (p.notBefore <= time) OR (p.notBefore <= time) & (time < 0) THEN + p.next := NIL; Exec(p) (* warning: p may call DoLater or RemoveAction, + which change the lists! *) + ELSE + p.next := actions; actions := p (* move to actions list for later processing *) + END + END + END IterateOverActions; + + + PROCEDURE (h: ActionHook) Step*, NEW, ABSTRACT; + + PROCEDURE (h: ActionHook) Loop*, NEW, ABSTRACT; + + + PROCEDURE (h: StdHook) Step; + BEGIN + IF (candidates = NIL) OR (trapCnt < Kernel.trapCount) THEN + IterateOverActions(Ticks()) + END + END Step; + + PROCEDURE (h: StdHook) Loop; + BEGIN + IF hasImmediates THEN + ASSERT((candidates = NIL) OR (trapCnt < Kernel.trapCount), 100); + IterateOverActions(immediately); + hasImmediates := FALSE + END + END Loop; + + + (* type handling functions *) + + PROCEDURE ThisDesc (IN type: ARRAY OF CHAR; load: BOOLEAN): Kernel.Type; + CONST record = 1; pointer = 3; + VAR m: Kernel.Module; t: Kernel.Type; i, j: INTEGER; ch: CHAR; + typ: Kernel.Name; mod: ARRAY 256 OF CHAR; + BEGIN + ASSERT(type # "", 20); + i := 0; ch := type[0]; + WHILE (ch # ".") & (ch # 0X) DO mod[i] := ch; INC(i); ch := type[i] END; + ASSERT(ch = ".", 21); + mod[i] := 0X; INC(i); t := NIL; + IF load THEN + m := Kernel.ThisMod(mod) + ELSE typ := SHORT(mod$); m := Kernel.ThisLoadedMod(typ) + END; + + IF m # NIL THEN + j := 0; REPEAT ch := type[i]; typ[j] := SHORT(ch); INC(i); INC(j) UNTIL ch = 0X; + t := Kernel.ThisType(m, typ); + IF t = NIL THEN typ[j - 1] := "^"; typ[j] := 0X; t := Kernel.ThisType(m, typ) END + END; + IF t # NIL THEN + IF t.id MOD 4 = pointer THEN t := t.base[0] END; + IF t.id MOD 4 # record THEN t := NIL END + END; + RETURN t + END ThisDesc; + + PROCEDURE GetTypeName* (IN rec: ANYREC; OUT type: ARRAY OF CHAR); + VAR i, j: INTEGER; ch: CHAR; t: Kernel.Type; name: Kernel.Name; + BEGIN + t := Kernel.TypeOf(rec); + Kernel.GetTypeName(t, name); type := t.mod.name$; + i := 0; ch := type[0]; WHILE ch # 0X DO INC(i); ch := type[i] END; + type[i] := "."; INC(i); + j := 0; REPEAT ch := name[j]; type[i] := ch; INC(i); INC(j) UNTIL ch = 0X; + IF type[i - 2] = "^" THEN type[i - 2] := 0X END + END GetTypeName; + + PROCEDURE SameType* (IN ra, rb: ANYREC): BOOLEAN; + BEGIN + RETURN Kernel.TypeOf(ra) = Kernel.TypeOf(rb) + END SameType; + + PROCEDURE IsExtensionOf* (IN ra, rb: ANYREC): BOOLEAN; + VAR ta, tb: Kernel.Type; + BEGIN + ta := Kernel.TypeOf(ra); tb := Kernel.TypeOf(rb); + RETURN ta.base[tb.id DIV 16 MOD 16] = tb + END IsExtensionOf; + + PROCEDURE Is* (IN rec: ANYREC; IN type: ARRAY OF CHAR): BOOLEAN; + VAR ta, tb: Kernel.Type; + BEGIN + ta := Kernel.TypeOf(rec); tb := ThisDesc(type, FALSE); + IF tb # NIL THEN RETURN ta.base[tb.id DIV 16 MOD 16] = tb + ELSE RETURN FALSE + END + END Is; + + PROCEDURE Extends* (IN type, base: ARRAY OF CHAR): BOOLEAN; + VAR ta, tb: Kernel.Type; + BEGIN + ASSERT((type # "") & (base # ""), 20); + ta := ThisDesc(type, TRUE); tb := ThisDesc(base, FALSE); + IF (ta # NIL) & (tb # NIL) THEN RETURN ta.base[tb.id DIV 16 MOD 16] = tb + ELSE RETURN FALSE + END + END Extends; + + PROCEDURE Level* (IN type: ARRAY OF CHAR): INTEGER; + VAR t: Kernel.Type; + BEGIN + t := ThisDesc(type, TRUE); + RETURN t.id DIV 16 MOD 16 + END Level; + + PROCEDURE TypeLevel* (IN rec: ANYREC): INTEGER; + VAR t: Kernel.Type; + BEGIN + t := Kernel.TypeOf(rec); + IF t = NIL THEN RETURN -1 + ELSE RETURN t.id DIV 16 MOD 16 + END + END TypeLevel; + + PROCEDURE AdrOf* (IN rec: ANYREC): INTEGER; + BEGIN + RETURN SYSTEM.ADR(rec) + END AdrOf; + + PROCEDURE Collect*; + BEGIN + Kernel.FastCollect + END Collect; + + + PROCEDURE Init; + VAR h: StdHook; + BEGIN + NEW(h); actionHook := h + END Init; + +BEGIN + Init +END Services. diff --git a/Trurl-based/System/Mod/Stores.txt b/Trurl-based/System/Mod/Stores.txt new file mode 100644 index 0000000..e51dc2c --- /dev/null +++ b/Trurl-based/System/Mod/Stores.txt @@ -0,0 +1,1313 @@ +MODULE Stores; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Stores.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel, Dialog, Strings, Files; + + CONST + (** Alien.cause, Reader.TurnIntoAlien cause - flagged by internalization procs **) + alienVersion* = 1; alienComponent* = 2; + (** Alien.cause - internally detected **) + inconsistentVersion* = -1; inconsistentType* = -2; + moduleFileNotFound* = -3; invalidModuleFile* = -4; + inconsModuleVersion* = -5; typeNotFound* = -6; + + dictLineLen = 32; (* length of type & elem dict lines *) + + newBase = 0F0X; (* new base type (level = 0), i.e. not yet in dict *) + newExt = 0F1X; (* new extension type (level = 1), i.e. not yet in dict *) + oldType = 0F2X; (* old type, i.e. already in dict *) + + nil = 080X; (* nil store *) + link = 081X; (* link to another elem in same file *) + store = 082X; (* general store *) + elem = 083X; (* elem store *) + newlink = 084X; (* link to another non-elem store in same file *) + + minVersion = 0; maxStoreVersion = 0; + + elemTName = "Stores.ElemDesc"; (* type of pre-1.3 elems *) + modelTName = "Models.ModelDesc"; (* the only known family of pre-1.3 elems *) + + inited = TRUE; anonymousDomain = FALSE; (* values to be used when calling NewDomain *) + + compatible = TRUE; + + + TYPE + TypeName* = ARRAY 64 OF CHAR; + TypePath* = ARRAY 16 OF TypeName; + OpName* = ARRAY 32 OF CHAR; + + Domain* = POINTER TO LIMITED RECORD + sequencer: ANYPTR; + dlink: Domain; + initialized, copyDomain: BOOLEAN; + level, copyera, nextElemId: INTEGER; + sDict: StoreDict; + cleaner: TrapCleaner; + s: Store (* used for CopyOf *) + END; + + Operation* = POINTER TO ABSTRACT RECORD END; + + Store* = POINTER TO ABSTRACT RECORD + dlink: Domain; + era, id: INTEGER; (* externalization era and id *) + isElem: BOOLEAN (* to preserve file format: is this an elem in the old sense? *) + END; + + + AlienComp* = POINTER TO LIMITED RECORD + next-: AlienComp + END; + + AlienPiece* = POINTER TO LIMITED RECORD (AlienComp) + pos-, len-: INTEGER + END; + + AlienPart* = POINTER TO LIMITED RECORD (AlienComp) + store-: Store + END; + + Alien* = POINTER TO LIMITED RECORD (Store) + path-: TypePath; (** the type this store would have if it were not an alien **) + cause-: INTEGER; (** # 0, the cause that turned this store into an alien **) + file-: Files.File; (** base file holding alien pieces **) + comps-: AlienComp (** the constituent components of this alien store **) + END; + + ReaderState = RECORD + next: INTEGER; (* position of next store in current level *) + end: INTEGER (* position just after last read store *) + END; + + WriterState = RECORD + linkpos: INTEGER (* address of threading link *) + END; + + TypeDict = POINTER TO RECORD + next: TypeDict; + org: INTEGER; (* origin id of this dict line *) + type: ARRAY dictLineLen OF TypeName; (* type[org] .. type[org + dictLineLen - 1] *) + baseId: ARRAY dictLineLen OF INTEGER + END; + + StoreDict = POINTER TO RECORD + next: StoreDict; + org: INTEGER; (* origin id of this dict line *) + elem: ARRAY dictLineLen OF Store (* elem[org] .. elem[org + dictLineLen - 1] *) + END; + + Reader* = RECORD + rider-: Files.Reader; + cancelled-: BOOLEAN; (** current Internalize has been cancelled **) + readAlien-: BOOLEAN; (** at least one alien read since ConnectTo **) + cause: INTEGER; + nextTypeId, nextElemId, nextStoreId: INTEGER; (* next id of non-dict type, "elem", store *) + tDict, tHead: TypeDict; (* mapping (id <-> type) - self-organizing list *) + eDict, eHead: StoreDict; (* mapping (id -> elem) - self-organizing list *) + sDict, sHead: StoreDict; (* mapping (id -> store) - self-organizing list *) + st: ReaderState; + noDomain: BOOLEAN; + store: Store + END; + + Writer* = RECORD + rider-: Files.Writer; + writtenStore-: Store; + era: INTEGER; (* current externalization era *) + noDomain: BOOLEAN; (* no domain encountered yet *) + modelType: Kernel.Type; + domain: Domain; (* domain of current era *) + nextTypeId, nextElemId, nextStoreId: INTEGER; (* next id of non-dict type or elem *) + tDict, tHead: TypeDict; (* mapping (id -> type) - self-organizing list *) + st: WriterState + END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) + d: Domain + END; + + VAR + nextEra: INTEGER; (* next externalization era *) + thisTypeRes: INTEGER; (* side-effect res code of ThisType *) + logReports: BOOLEAN; + + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + c.d.level := 0; + c.d.sDict := NIL; + c.d.s := NIL + END Cleanup; + + PROCEDURE (d: Domain) SetSequencer* (sequencer: ANYPTR), NEW; + BEGIN + ASSERT(d.sequencer = NIL); + d.sequencer := sequencer + END SetSequencer; + + PROCEDURE (d: Domain) GetSequencer*(): ANYPTR, NEW; + BEGIN + RETURN d.sequencer + END GetSequencer; + + + PROCEDURE^ Report* (IN msg, p0, p1, p2: ARRAY OF CHAR); + + PROCEDURE^ (VAR rd: Reader) SetPos* (pos: INTEGER), NEW; + PROCEDURE^ (VAR rd: Reader) ReadVersion* (min, max: INTEGER; OUT version: INTEGER), NEW; + PROCEDURE^ (VAR rd: Reader) ReadSChar* (OUT x: SHORTCHAR), NEW; + PROCEDURE^ (VAR rd: Reader) ReadInt* (OUT x: INTEGER), NEW; + PROCEDURE^ (VAR rd: Reader) ReadXString* (OUT x: ARRAY OF CHAR), NEW; + PROCEDURE^ (VAR rd: Reader) ReadStore* (OUT x: Store), NEW; + + PROCEDURE^ (VAR wr: Writer) SetPos* (pos: INTEGER), NEW; + PROCEDURE^ (VAR wr: Writer) WriteVersion* (version: INTEGER), NEW; + PROCEDURE^ (VAR wr: Writer) WriteSChar* (x: SHORTCHAR), NEW; + PROCEDURE^ (VAR wr: Writer) WriteInt* (x: INTEGER), NEW; + PROCEDURE^ (VAR wr: Writer) WriteXString* (IN x: ARRAY OF CHAR), NEW; + PROCEDURE^ (VAR wr: Writer) WriteStore* (x: Store), NEW; + + PROCEDURE^ Join* (s0, s1: Store); + + + (** Operation **) + + PROCEDURE (op: Operation) Do* (), NEW, ABSTRACT; + + + (** Store **) + + PROCEDURE NewDomain (initialized: BOOLEAN): Domain; + VAR d: Domain; + BEGIN + NEW(d); d.level := 0; d.sDict := NIL; d.cleaner := NIL; + d.initialized := initialized; d.copyDomain := FALSE; + RETURN d + END NewDomain; + + PROCEDURE DomainOf (s: Store): Domain; + VAR d, p, q, r: Domain; + BEGIN + d := s.dlink; + IF (d # NIL) & (d.dlink # NIL) THEN + p := NIL; q := d; r := q.dlink; + WHILE r # NIL DO q.dlink := p; p := q; q := r; r := q.dlink END; + d := q; + WHILE p # NIL DO q := p; p := q.dlink; q.dlink := d END; + s.dlink := d + END; + RETURN d + END DomainOf; + + PROCEDURE (s: Store) Domain*(): Domain, NEW; + VAR d: Domain; + BEGIN + d := DomainOf(s); + IF (d # NIL) & ~d.initialized THEN d := NIL END; + RETURN d + END Domain; + + PROCEDURE (s: Store) CopyFrom- (source: Store), NEW, EMPTY; + + PROCEDURE (s: Store) Internalize- (VAR rd: Reader), NEW, EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + rd.ReadVersion(minVersion, maxStoreVersion, thisVersion); + IF ~rd.cancelled & s.isElem THEN + rd.ReadVersion(minVersion, maxStoreVersion, thisVersion) + (* works since maxStoreVersion = maxElemVersion = 0 in pre-1.3 *) + END + END Internalize; + + PROCEDURE (s: Store) ExternalizeAs- (VAR s1: Store), NEW, EMPTY; + + PROCEDURE (s: Store) Externalize- (VAR wr: Writer), NEW, EXTENSIBLE; + BEGIN + wr.WriteVersion(maxStoreVersion); + IF s.isElem THEN wr.WriteVersion(maxStoreVersion) END + END Externalize; + + + (** Alien **) + + PROCEDURE^ CopyOf* (s: Store): Store; + + PROCEDURE (a: Alien) CopyFrom- (source: Store); + VAR s, c, cp: AlienComp; piece: AlienPiece; part: AlienPart; + BEGIN + WITH source: Alien DO + a.path := source.path; + a.cause := source.cause; + a.file := source.file; + a.comps := NIL; + s := source.comps; cp := NIL; + WHILE s # NIL DO + WITH s: AlienPiece DO + NEW(piece); c := piece; + piece.pos := s.pos; piece.len := s.len + | s: AlienPart DO + NEW(part); c := part; + IF s.store # NIL THEN part.store := CopyOf(s.store); Join(part.store, a) END + END; + IF cp # NIL THEN cp.next := c ELSE a.comps := c END; + cp := c; + s := s.next + END + END + END CopyFrom; + + PROCEDURE (a: Alien) Internalize- (VAR rd: Reader); + BEGIN + HALT(100) + END Internalize; + + PROCEDURE (a: Alien) Externalize- (VAR w: Writer); + BEGIN + HALT(100) + END Externalize; + + + (* types *) + + PROCEDURE GetThisTypeName (t: Kernel.Type; VAR type: TypeName); + VAR i, j: INTEGER; ch: CHAR; name: Kernel.Name; + BEGIN + Kernel.GetTypeName(t, name); type := t.mod.name$; + i := 0; ch := type[0]; WHILE ch # 0X DO INC(i); ch := type[i] END; + type[i] := "."; INC(i); + j := 0; REPEAT ch := name[j]; type[i] := ch; INC(i); INC(j) UNTIL ch = 0X; + IF compatible THEN + IF type[i-2] = "^" THEN (* for backward compatibility *) + type[i-2] := "D"; type[i-1] := "e"; type[i] := "s"; type[i+1] := "c"; type[i+2] := 0X + END + END + END GetThisTypeName; + + PROCEDURE ThisType (type: TypeName): Kernel.Type; + VAR m: Kernel.Module; t: Kernel.Type; i, j: INTEGER; ch: CHAR; + typ: Kernel.Name; mod: ARRAY 256 OF CHAR; res: INTEGER; str: ARRAY 256 OF CHAR; + BEGIN + ASSERT(type # "", 20); + i := 0; ch := type[0]; + WHILE (ch # ".") & (ch # 0X) DO mod[i] := SHORT(ch); INC(i); ch := type[i] END; + ASSERT(ch = ".", 21); + mod[i] := 0X; INC(i); + m := Kernel.ThisMod(mod); + IF m # NIL THEN + j := 0; REPEAT ch := type[i]; typ[j] := SHORT(ch); INC(i); INC(j) UNTIL ch = 0X; + t := Kernel.ThisType(m, typ); + IF (t = NIL) & (j >= 5) THEN (* try pointer type *) + IF (typ[j-5] = "D") & (typ[j-4] = "e") & (typ[j-3] = "s") & (typ[j-2] = "c") THEN + typ[j-5] := "^"; typ[j-4] := 0X; + t := Kernel.ThisType(m, typ) + END + END; + IF t = NIL THEN thisTypeRes := typeNotFound END + ELSE + t := NIL; + Kernel.GetLoaderResult(res, str, str, str); + CASE res OF + | Kernel.fileNotFound: thisTypeRes := moduleFileNotFound + | Kernel.syntaxError: thisTypeRes := invalidModuleFile + | Kernel.objNotFound: thisTypeRes := inconsModuleVersion + | Kernel.illegalFPrint: thisTypeRes := inconsModuleVersion + | Kernel.cyclicImport: thisTypeRes := invalidModuleFile (* cyclic import ... *) + ELSE thisTypeRes := invalidModuleFile + END + END; + RETURN t + END ThisType; + + PROCEDURE SameType (IN x, y: TypeName): BOOLEAN; + VAR i: INTEGER; + BEGIN + IF x = y THEN RETURN TRUE + ELSE + i := 0; WHILE x[i] = y[i] DO INC(i) END; + RETURN + (x[i] = "^") & (x[i+1] = 0X) & (y[i] = "D") & (y[i+1] = "e") & (y[i+2] = "s") & (y[i+3] = "c") & (y[i+4] = 0X) + OR (y[i] = "^") & (y[i+1] = 0X) & (x[i] = "D") & (x[i+1] = "e") & (x[i+2] = "s") & (x[i+3] = "c") & (x[i+4] = 0X) + END + END SameType; + + PROCEDURE SamePath (t: Kernel.Type; VAR path: TypePath): BOOLEAN; + (* check whether t coincides with path *) + VAR tn: TypeName; i, n: INTEGER; + BEGIN + i := -1; n := Kernel.LevelOf(t); + REPEAT + GetThisTypeName(t.base[n], tn); + DEC(n); INC(i) + UNTIL (n < 0) OR ~SameType(tn, path[i]); + RETURN SameType(tn, path[i]) + END SamePath; + + PROCEDURE NewStore (t: Kernel.Type): Store; + VAR p: ANYPTR; + BEGIN + ASSERT(t # NIL, 20); + Kernel.NewObj(p, t); ASSERT(p # NIL, 100); + ASSERT(p IS Store, 21); + RETURN p(Store) + END NewStore; + + + (* type dictionary *) + + PROCEDURE GetThisType (VAR d: TypeDict; id: INTEGER; VAR type: TypeName); + (* pre: (id, t) IN dict *) + VAR h, p: TypeDict; org, k: INTEGER; + BEGIN + k := id MOD dictLineLen; org := id - k; + h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END; + IF h # NIL THEN h.next := p.next; p.next := d; d := p END; + type := p.type[k]; + ASSERT(type # "", 100) + END GetThisType; + + PROCEDURE ThisId (VAR d: TypeDict; t: TypeName): INTEGER; + (* pre: t # "" *) + (* post: res = id if (t, id) in dict, res = -1 else *) + VAR h, p: TypeDict; k, id: INTEGER; + BEGIN + h := NIL; p := d; id := -1; + WHILE (p # NIL) & (id < 0) DO + k := 0; WHILE (k < dictLineLen) & (p.type[k, 0] # 0X) & (p.type[k] # t) DO INC(k) END; + IF (k < dictLineLen) & (p.type[k, 0] # 0X) THEN id := p.org + k + ELSE h := p; p := p.next + END + END; + IF (id >= 0) & (h # NIL) THEN h.next := p.next; p.next := d; d := p END; + RETURN id + END ThisId; + + PROCEDURE ThisBaseId (VAR d: TypeDict; id: INTEGER): INTEGER; + (* post: res = id if base(t) # NIL, res = -1 if base(t) = NIL; res >= 0 => T(res) = base(t) *) + VAR h, p: TypeDict; k, org, baseId: INTEGER; + BEGIN + k := id MOD dictLineLen; org := id - k; + h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END; + IF h # NIL THEN h.next := p.next; p.next := d; d := p END; + baseId := p.baseId[k]; + RETURN baseId + END ThisBaseId; + + PROCEDURE AddType (VAR d, h: TypeDict; id: INTEGER; type: TypeName); + VAR k: INTEGER; + BEGIN + k := id MOD dictLineLen; + IF (h = NIL) OR ((k = 0) & (h.org # id)) THEN + NEW(h); h.org := id - k; h.next := d; d := h + END; + h.type[k] := type; h.baseId[k] := -1 + END AddType; + + PROCEDURE AddBaseId (h: TypeDict; id, baseId: INTEGER); + VAR k: INTEGER; + BEGIN + k := id MOD dictLineLen; + h.baseId[k] := baseId + END AddBaseId; + + PROCEDURE InitTypeDict (VAR d, h: TypeDict; VAR nextID: INTEGER); + BEGIN + d := NIL; h := NIL; nextID := 0 + END InitTypeDict; + + + (* store dictionary - used to maintain referential sharing *) + + PROCEDURE ThisStore (VAR d: StoreDict; id: INTEGER): Store; + (* pre: (id, s) IN dict *) + VAR h, p: StoreDict; s: Store; k, org: INTEGER; + BEGIN + k := id MOD dictLineLen; org := id - k; + h := NIL; p := d; WHILE p.org # org DO h := p; p := p.next END; + IF h # NIL THEN h.next := p.next; p.next := d; d := p END; + s := p.elem[k]; + ASSERT(s # NIL, 100); + RETURN s + END ThisStore; + + PROCEDURE AddStore (VAR d, h: StoreDict; s: Store); + VAR k: INTEGER; + BEGIN + k := s.id MOD dictLineLen; + IF (h = NIL) OR ((k = 0) & (h.org # s.id)) THEN + NEW(h); h.org := s.id - k; h.next := d; d := h + END; + h.elem[k] := s + END AddStore; + + PROCEDURE InitStoreDict (VAR d, h: StoreDict; VAR nextID: INTEGER); + BEGIN + d := NIL; h := NIL; nextID := 0 + END InitStoreDict; + + + (* support for type mapping *) + + PROCEDURE ReadPath (VAR rd: Reader; VAR path: TypePath); + VAR h: TypeDict; id, extId: INTEGER; i: INTEGER; kind: SHORTCHAR; + + PROCEDURE AddPathComp (VAR rd: Reader); + BEGIN + IF h # NIL THEN AddBaseId(h, extId, rd.nextTypeId) END; + AddType(rd.tDict, rd.tHead, rd.nextTypeId, path[i]); + h := rd.tHead; extId := rd.nextTypeId + END AddPathComp; + + BEGIN + h := NIL; i := 0; rd.ReadSChar(kind); + WHILE kind = newExt DO + rd.ReadXString(path[i]); + AddPathComp(rd); INC(rd.nextTypeId); + IF path[i] # elemTName THEN INC(i) END; + rd.ReadSChar(kind) + END; + IF kind = newBase THEN + rd.ReadXString(path[i]); + AddPathComp(rd); INC(rd.nextTypeId); INC(i) + ELSE + ASSERT(kind = oldType, 100); + rd.ReadInt(id); + IF h # NIL THEN AddBaseId(h, extId, id) END; + REPEAT + GetThisType(rd.tDict, id, path[i]); id := ThisBaseId(rd.tDict, id); + IF path[i] # elemTName THEN INC(i) END + UNTIL id = -1 + END; + path[i] := "" + END ReadPath; + + PROCEDURE WritePath (VAR wr: Writer; VAR path: TypePath); + VAR h: TypeDict; id, extId: INTEGER; i, n: INTEGER; + BEGIN + h := NIL; + n := 0; WHILE path[n] # "" DO INC(n) END; + i := 0; + WHILE i < n DO + id := ThisId(wr.tDict, path[i]); + IF id >= 0 THEN + IF h # NIL THEN AddBaseId(h, extId, id) END; + wr.WriteSChar(oldType); wr.WriteInt(id); n := i + ELSE + IF i + 1 < n THEN wr.WriteSChar(newExt) ELSE wr.WriteSChar(newBase) END; + wr.WriteXString(path[i]); + IF h # NIL THEN AddBaseId(h, extId, wr.nextTypeId) END; + AddType(wr.tDict, wr.tHead, wr.nextTypeId, path[i]); + h := wr.tHead; extId := wr.nextTypeId; + INC(wr.nextTypeId); + IF path[i] = modelTName THEN + id := ThisId(wr.tDict, elemTName); ASSERT(id < 0, 100); ASSERT(i + 2 = n, 101); + wr.WriteSChar(newExt); wr.WriteXString(elemTName); + IF h # NIL THEN AddBaseId(h, extId, wr.nextTypeId) END; + AddType(wr.tDict, wr.tHead, wr.nextTypeId, elemTName); + h := wr.tHead; extId := wr.nextTypeId; + INC(wr.nextTypeId) + END + END; + INC(i) + END + END WritePath; + + PROCEDURE WriteType (VAR wr: Writer; t: Kernel.Type); + VAR path: TypePath; n, i: INTEGER; + BEGIN + i := 0; n := Kernel.LevelOf(t); + WHILE n >= 0 DO + GetThisTypeName(t.base[n], path[i]); + DEC(n); INC(i) + END; + path[i] := ""; + WritePath(wr, path) + END WriteType; + + + (* support for alien mapping *) + + PROCEDURE InternalizeAlien (VAR rd: Reader; VAR comps: AlienComp; down, pos, len: INTEGER); + VAR h, p: AlienComp; piece: AlienPiece; part: AlienPart; file: Files.File; + next, end, max: INTEGER; + BEGIN + file := rd.rider.Base(); max := file.Length(); + end := pos + len; h := NIL; + IF down # 0 THEN next := down ELSE next := end END; + WHILE pos < end DO + ASSERT(end <= max, 100); + IF pos < next THEN + NEW(piece); piece.pos := pos; piece.len := next - pos; + p := piece; pos := next + ELSE + ASSERT(pos = next, 101); + rd.SetPos(next); + NEW(part); rd.ReadStore(part.store); + ASSERT(rd.st.end > next, 102); + p := part; pos := rd.st.end; + IF rd.st.next > 0 THEN + ASSERT(rd.st.next > next, 103); next := rd.st.next + ELSE next := end + END + END; + IF h = NIL THEN comps := p ELSE h.next := p END; + h := p + END; + ASSERT(pos = end, 104); + rd.SetPos(end) + END InternalizeAlien; + + PROCEDURE ExternalizePiece (VAR wr: Writer; file: Files.File; p: AlienPiece); + VAR r: Files.Reader; w: Files.Writer; b: BYTE; l, len: INTEGER; + BEGIN + l := file.Length(); len := p.len; + ASSERT(0 <= p.pos, 100); ASSERT(p.pos <= l, 101); + ASSERT(0 <= len, 102); ASSERT(len <= l - p.pos, 103); + r := file.NewReader(NIL); r.SetPos(p.pos); + w := wr.rider; + WHILE len # 0 DO r.ReadByte(b); w.WriteByte(b); DEC(len) END + END ExternalizePiece; + + PROCEDURE ExternalizeAlien (VAR wr: Writer; file: Files.File; comps: AlienComp); + VAR p: AlienComp; + BEGIN + p := comps; + WHILE p # NIL DO + WITH p: AlienPiece DO + ExternalizePiece(wr, file, p) + | p: AlienPart DO + wr.WriteStore(p.store) + END; + p := p.next + END + END ExternalizeAlien; + + + (** Reader **) + + PROCEDURE (VAR rd: Reader) ConnectTo* (f: Files.File), NEW; + (** pre: rd.rider = NIL OR f = NIL **) + BEGIN + IF f = NIL THEN + rd.rider := NIL + ELSE + ASSERT(rd.rider = NIL, 20); + rd.rider := f.NewReader(rd.rider); rd.SetPos(0); + InitTypeDict(rd.tDict, rd.tHead, rd.nextTypeId); + InitStoreDict(rd.eDict, rd.eHead, rd.nextElemId); + InitStoreDict(rd.sDict, rd.sHead, rd.nextStoreId); + rd.noDomain := TRUE + END; + rd.readAlien := FALSE + END ConnectTo; + + PROCEDURE (VAR rd: Reader) SetPos* (pos: INTEGER), NEW; + BEGIN + rd.rider.SetPos(pos) + END SetPos; + + PROCEDURE (VAR rd: Reader) Pos* (): INTEGER, NEW; + BEGIN + RETURN rd.rider.Pos() + END Pos; + + PROCEDURE (VAR rd: Reader) ReadBool* (OUT x: BOOLEAN), NEW; + VAR b: BYTE; + BEGIN + rd.rider.ReadByte(b); x := b # 0 + END ReadBool; + + PROCEDURE (VAR rd: Reader) ReadSChar* (OUT x: SHORTCHAR), NEW; + BEGIN + rd.rider.ReadByte(SYSTEM.VAL(BYTE, x)) + END ReadSChar; + + PROCEDURE (VAR rd: Reader) ReadXChar* (OUT x: CHAR), NEW; + VAR c: SHORTCHAR; + BEGIN + rd.rider.ReadByte(SYSTEM.VAL(BYTE,c)); x := c + END ReadXChar; + + PROCEDURE (VAR rd: Reader) ReadChar* (OUT x: CHAR), NEW; + VAR le: ARRAY 2 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 2); + x := CHR(le[0] MOD 256 + (le[1] MOD 256) * 256) + END ReadChar; + + PROCEDURE (VAR rd: Reader) ReadByte* (OUT x: BYTE), NEW; + BEGIN + rd.rider.ReadByte(x) + END ReadByte; + + PROCEDURE (VAR rd: Reader) ReadSInt* (OUT x: SHORTINT), NEW; + VAR le, be: ARRAY 2 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 2); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(SHORTINT, le) + ELSE + be[0] := le[1]; be[1] := le[0]; + x := SYSTEM.VAL(SHORTINT, be) + END + END ReadSInt; + + PROCEDURE (VAR rd: Reader) ReadXInt* (OUT x: INTEGER), NEW; + VAR le, be: ARRAY 2 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 2); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(SHORTINT, le) + ELSE + be[0] := le[1]; be[1] := le[0]; + x := SYSTEM.VAL(SHORTINT, be) + END + END ReadXInt; + + PROCEDURE (VAR rd: Reader) ReadInt* (OUT x: INTEGER), NEW; + VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 4); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(INTEGER, le) + ELSE + be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0]; + x := SYSTEM.VAL(INTEGER, be) + END + END ReadInt; + + PROCEDURE (VAR rd: Reader) ReadLong* (OUT x: LONGINT), NEW; + VAR le, be: ARRAY 8 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 8); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(LONGINT, le) + ELSE + be[0] := le[7]; be[1] := le[6]; be[2] := le[5]; be[3] := le[4]; + be[4] := le[3]; be[5] := le[2]; be[6] := le[1]; be[7] := le[0]; + x := SYSTEM.VAL(LONGINT, be) + END + END ReadLong; + + PROCEDURE (VAR rd: Reader) ReadSReal* (OUT x: SHORTREAL), NEW; + VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 4); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(SHORTREAL, le) + ELSE + be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0]; + x := SYSTEM.VAL(SHORTREAL, be) + END + END ReadSReal; + + PROCEDURE (VAR rd: Reader) ReadXReal* (OUT x: REAL), NEW; + VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 4); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(SHORTREAL, le) + ELSE + be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0]; + x := SYSTEM.VAL(SHORTREAL, be) + END + END ReadXReal; + + PROCEDURE (VAR rd: Reader) ReadReal* (OUT x: REAL), NEW; + VAR le, be: ARRAY 8 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 8); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(REAL, le) + ELSE + be[0] := le[7]; be[1] := le[6]; be[2] := le[5]; be[3] := le[4]; + be[4] := le[3]; be[5] := le[2]; be[6] := le[1]; be[7] := le[0]; + x := SYSTEM.VAL(REAL, be) + END + END ReadReal; + + PROCEDURE (VAR rd: Reader) ReadSet* (OUT x: SET), NEW; + VAR le, be: ARRAY 4 OF BYTE; (* little endian, big endian *) + BEGIN + rd.rider.ReadBytes(le, 0, 4); + IF Kernel.littleEndian THEN + x := SYSTEM.VAL(SET, le) + ELSE + be[0] := le[3]; be[1] := le[2]; be[2] := le[1]; be[3] := le[0]; + x := SYSTEM.VAL(SET, be) + END + END ReadSet; + + PROCEDURE (VAR rd: Reader) ReadSString* (OUT x: ARRAY OF SHORTCHAR), NEW; + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; REPEAT rd.ReadSChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X + END ReadSString; + + PROCEDURE (VAR rd: Reader) ReadXString* (OUT x: ARRAY OF CHAR), NEW; + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; REPEAT rd.ReadXChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X + END ReadXString; + + PROCEDURE (VAR rd: Reader) ReadString* (OUT x: ARRAY OF CHAR), NEW; + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; REPEAT rd.ReadChar(ch); x[i] := ch; INC(i) UNTIL ch = 0X + END ReadString; + + PROCEDURE AlienReport (cause: INTEGER); + VAR s, e: ARRAY 32 OF CHAR; + BEGIN + CASE cause OF + | alienVersion: s := "#System:AlienVersion" + | alienComponent: s := "#System:AlienComponent" + | inconsistentVersion: s := "#System:InconsistentVersion" + ELSE s := "#System:UnknownCause" + END; + Strings.IntToString(cause, e); + Report("#System:AlienCause ^0 ^1 ^2", s, e, "") + END AlienReport; + + PROCEDURE AlienTypeReport (cause: INTEGER; t: ARRAY OF CHAR); + VAR s: ARRAY 64 OF CHAR; + BEGIN + CASE cause OF + | inconsistentType: s := "#System:InconsistentType ^0" + | moduleFileNotFound: s := "#System:CodeFileNotFound ^0" + | invalidModuleFile: s := "#System:InvalidCodeFile ^0" + | inconsModuleVersion: s := "#System:InconsistentModuleVersion ^0" + | typeNotFound: s := "#System:TypeNotFound ^0" + END; + Report(s, t, "", "") + END AlienTypeReport; + + PROCEDURE (VAR rd: Reader) TurnIntoAlien* (cause: INTEGER), NEW; + BEGIN + ASSERT(cause > 0, 20); + rd.cancelled := TRUE; rd.readAlien := TRUE; rd.cause := cause; + AlienReport(cause) + END TurnIntoAlien; + + PROCEDURE (VAR rd: Reader) ReadVersion* (min, max: INTEGER; OUT version: INTEGER), NEW; + VAR v: BYTE; + BEGIN + rd.ReadByte(v); version := v; + IF (version < min) OR (version > max) THEN + rd.TurnIntoAlien(alienVersion) + END + END ReadVersion; + + PROCEDURE (VAR rd: Reader) ReadStore* (OUT x: Store), NEW; + VAR a: Alien; t: Kernel.Type; + len, pos, pos1, id, comment, next, down, downPos, nextTypeId, nextElemId, nextStoreId: INTEGER; + kind: SHORTCHAR; path: TypePath; type: TypeName; + save: ReaderState; + BEGIN + rd.ReadSChar(kind); + IF kind = nil THEN + rd.ReadInt(comment); rd.ReadInt(next); + rd.st.end := rd.Pos(); + IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END; + x := NIL + ELSIF kind = link THEN + rd.ReadInt(id); rd.ReadInt(comment); rd.ReadInt(next); + rd.st.end := rd.Pos(); + IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END; + x := ThisStore(rd.eDict, id) + ELSIF kind = newlink THEN + rd.ReadInt(id); rd.ReadInt(comment); rd.ReadInt(next); + rd.st.end := rd.Pos(); + IF (next > 0) OR ((next = 0) & ODD(comment)) THEN rd.st.next := rd.st.end + next ELSE rd.st.next := 0 END; + x := ThisStore(rd.sDict, id) + ELSIF (kind = store) OR (kind = elem) THEN + IF kind = elem THEN + id := rd.nextElemId; INC(rd.nextElemId) + ELSE + id := rd.nextStoreId; INC(rd.nextStoreId) + END; + ReadPath(rd, path); type := path[0]; + nextTypeId := rd.nextTypeId; nextElemId := rd.nextElemId; nextStoreId := rd.nextStoreId; + rd.ReadInt(comment); + pos1 := rd.Pos(); + rd.ReadInt(next); rd.ReadInt(down); rd.ReadInt(len); + pos := rd.Pos(); + IF next > 0 THEN rd.st.next := pos1 + next + 4 ELSE rd.st.next := 0 END; + IF down > 0 THEN downPos := pos1 + down + 8 ELSE downPos := 0 END; + rd.st.end := pos + len; + rd.cause := 0; + ASSERT(len >= 0, 101); + IF next # 0 THEN + ASSERT(rd.st.next > pos1, 102); + IF down # 0 THEN + ASSERT(downPos < rd.st.next, 103) + END + END; + IF down # 0 THEN + ASSERT(downPos > pos1, 104); + ASSERT(downPos < rd.st.end, 105) + END; + t := ThisType(type); + IF t # NIL THEN + x := NewStore(t); x.isElem := kind = elem + ELSE + rd.cause := thisTypeRes; AlienTypeReport(rd.cause, type); + x := NIL + END; + IF x # NIL THEN + IF SamePath(t, path) THEN + IF kind = elem THEN + x.id := id; AddStore(rd.eDict, rd.eHead, x) + ELSE + x.id := id; AddStore(rd.sDict, rd.sHead, x) + END; + save := rd.st; rd.cause := 0; rd.cancelled := FALSE; + x.Internalize(rd); + rd.st := save; + IF rd.cause # 0 THEN x := NIL + ELSIF (rd.Pos() # rd.st.end) OR rd.rider.eof THEN + rd.cause := inconsistentVersion; AlienReport(rd.cause); + x := NIL + END + ELSE + rd.cause := inconsistentType; AlienTypeReport(rd.cause, type); + x := NIL + END + END; + + IF x # NIL THEN + IF rd.noDomain THEN + rd.store := x; + rd.noDomain := FALSE + ELSE + Join(rd.store, x) + END + ELSE (* x is an alien *) + rd.SetPos(pos); + ASSERT(rd.cause # 0, 107); + NEW(a); a.path := path; a.cause := rd.cause; a.file := rd.rider.Base(); + IF rd.noDomain THEN + rd.store := a; + rd.noDomain := FALSE + ELSE + Join(rd.store, a) + END; + IF kind = elem THEN + a.id := id; AddStore(rd.eDict, rd.eHead, a) + ELSE + a.id := id; AddStore(rd.sDict, rd.sHead, a) + END; + save := rd.st; + rd.nextTypeId := nextTypeId; rd.nextElemId := nextElemId; rd.nextStoreId := nextStoreId; + InternalizeAlien(rd, a.comps, downPos, pos, len); + rd.st := save; + x := a; + ASSERT(rd.Pos() = rd.st.end, 108); + rd.cause := 0; rd.cancelled := FALSE; rd.readAlien := TRUE + END + ELSE + pos := rd.Pos(); + HALT(20) + END + END ReadStore; + + + (** Writer **) + + PROCEDURE (VAR wr: Writer) ConnectTo* (f: Files.File), NEW; + (** pre: wr.rider = NIL OR f = NIL **) + BEGIN + IF f = NIL THEN + wr.rider := NIL + ELSE + ASSERT(wr.rider = NIL, 20); + wr.rider := f.NewWriter(wr.rider); wr.SetPos(f.Length()); + wr.era := nextEra; INC(nextEra); + wr.noDomain := TRUE; + wr.modelType := ThisType(modelTName); + InitTypeDict(wr.tDict, wr.tHead, wr.nextTypeId); + wr.nextElemId := 0; wr.nextStoreId := 0; + wr.st.linkpos := -1 + END; + wr.writtenStore := NIL + END ConnectTo; + + PROCEDURE (VAR wr: Writer) SetPos* (pos: INTEGER), NEW; + BEGIN + wr.rider.SetPos(pos) + END SetPos; + + PROCEDURE (VAR wr: Writer) Pos* (): INTEGER, NEW; + BEGIN + RETURN wr.rider.Pos() + END Pos; + + PROCEDURE (VAR wr: Writer) WriteBool* (x: BOOLEAN), NEW; + BEGIN + IF x THEN wr.rider.WriteByte(1) ELSE wr.rider.WriteByte(0) END + END WriteBool; + + PROCEDURE (VAR wr: Writer) WriteSChar* (x: SHORTCHAR), NEW; + BEGIN + wr.rider.WriteByte(SYSTEM.VAL(BYTE, x)) + END WriteSChar; + + PROCEDURE (VAR wr: Writer) WriteXChar* (x: CHAR), NEW; + VAR c: SHORTCHAR; + BEGIN + c := SHORT(x); wr.rider.WriteByte(SYSTEM.VAL(BYTE, c)) + END WriteXChar; + + PROCEDURE (VAR wr: Writer) WriteChar* (x: CHAR), NEW; + TYPE a = ARRAY 2 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[1]; le[1] := be[0] + END; + wr.rider.WriteBytes(le, 0, 2) + END WriteChar; + + PROCEDURE (VAR wr: Writer) WriteByte* (x: BYTE), NEW; + BEGIN + wr.rider.WriteByte(x) + END WriteByte; + + PROCEDURE (VAR wr: Writer) WriteSInt* (x: SHORTINT), NEW; + TYPE a = ARRAY 2 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[1]; le[1] := be[0] + END; + wr.rider.WriteBytes(le, 0, 2) + END WriteSInt; + + PROCEDURE (VAR wr: Writer) WriteXInt* (x: INTEGER), NEW; + TYPE a = ARRAY 2 OF BYTE; + VAR y: SHORTINT; le, be: a; (* little endian, big endian *) + BEGIN + y := SHORT(x); + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, y) + ELSE + be := SYSTEM.VAL(a, y); + le[0] := be[1]; le[1] := be[0] + END; + wr.rider.WriteBytes(le, 0, 2) + END WriteXInt; + + PROCEDURE (VAR wr: Writer) WriteInt* (x: INTEGER), NEW; + TYPE a = ARRAY 4 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0] + END; + wr.rider.WriteBytes(le, 0, 4) + END WriteInt; + + PROCEDURE (VAR wr: Writer) WriteLong* (x: LONGINT), NEW; + TYPE a = ARRAY 8 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[7]; le[1] := be[6]; le[2] := be[5]; le[3] := be[4]; + le[4] := be[3]; le[5] := be[2]; le[6] := be[1]; le[7] := be[0] + END; + wr.rider.WriteBytes(le, 0, 8) + END WriteLong; + + PROCEDURE (VAR wr: Writer) WriteSReal* (x: SHORTREAL), NEW; + TYPE a = ARRAY 4 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0] + END; + wr.rider.WriteBytes(le, 0, 4) + END WriteSReal; + + PROCEDURE (VAR wr: Writer) WriteXReal* (x: REAL), NEW; + TYPE a = ARRAY 4 OF BYTE; + VAR y: SHORTREAL; le, be: a; (* little endian, big endian *) + BEGIN + y := SHORT(x); + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, y) + ELSE + be := SYSTEM.VAL(a, y); + le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0] + END; + wr.rider.WriteBytes(le, 0, 4) + END WriteXReal; + + PROCEDURE (VAR wr: Writer) WriteReal* (x: REAL), NEW; + TYPE a = ARRAY 8 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[7]; le[1] := be[6]; le[2] := be[5]; le[3] := be[4]; + le[4] := be[3]; le[5] := be[2]; le[6] := be[1]; le[7] := be[0] + END; + wr.rider.WriteBytes(le, 0, 8) + END WriteReal; + + PROCEDURE (VAR wr: Writer) WriteSet* (x: SET), NEW; + (* SIZE(SET) = 4 *) + TYPE a = ARRAY 4 OF BYTE; + VAR le, be: a; (* little endian, big endian *) + BEGIN + IF Kernel.littleEndian THEN + le := SYSTEM.VAL(a, x) + ELSE + be := SYSTEM.VAL(a, x); + le[0] := be[3]; le[1] := be[2]; le[2] := be[1]; le[3] := be[0] + END; + wr.rider.WriteBytes(le, 0, 4) + END WriteSet; + + PROCEDURE (VAR wr: Writer) WriteSString* (IN x: ARRAY OF SHORTCHAR), NEW; + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteSChar(ch); INC(i); ch := x[i] END; + wr.WriteSChar(0X) + END WriteSString; + + PROCEDURE (VAR wr: Writer) WriteXString* (IN x: ARRAY OF CHAR), NEW; + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteXChar(ch); INC(i); ch := x[i] END; + wr.WriteSChar(0X) + END WriteXString; + + PROCEDURE (VAR wr: Writer) WriteString* (IN x: ARRAY OF CHAR), NEW; + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; ch := x[0]; WHILE ch # 0X DO wr.WriteChar(ch); INC(i); ch := x[i] END; + wr.WriteChar(0X) + END WriteString; + + PROCEDURE (VAR wr: Writer) WriteVersion* (version: INTEGER), NEW; + BEGIN + wr.WriteByte(SHORT(SHORT(version))) + END WriteVersion; + + PROCEDURE (VAR wr: Writer) WriteStore* (x: Store), NEW; + VAR t: Kernel.Type; pos1, pos2, pos: INTEGER; + save: WriterState; + BEGIN + ASSERT(wr.rider # NIL, 20); + IF x # NIL THEN + IF wr.noDomain THEN + wr.domain := x.Domain(); wr.noDomain := FALSE + ELSE ASSERT(x.Domain() = wr.domain, 21) + END; + x.ExternalizeAs(x); IF x = NIL THEN wr.writtenStore := NIL; RETURN END + END; + IF wr.st.linkpos > 0 THEN (* link to previous block's or up block's *) + pos := wr.Pos(); + IF pos - wr.st.linkpos = 4 THEN + (* hack to resolve ambiguity between next = 0 because of end-of-chain, or because of offset = 0. + above guard holds only if for the latter case. + ASSUMPTION: + this can happen only if linkpos points to a next (not a down) + and there is a comment byte just before + *) + wr.SetPos(wr.st.linkpos - 4); wr.WriteInt(1); wr.WriteInt(pos - wr.st.linkpos - 4) + ELSE + wr.SetPos(wr.st.linkpos); wr.WriteInt(pos - wr.st.linkpos - 4) + END; + wr.SetPos(pos) + END; + IF x = NIL THEN + wr.WriteSChar(nil); + wr.WriteInt(0); (* *) + wr.st.linkpos := wr.Pos(); + wr.WriteInt(0) (* *) + ELSIF x.era >= wr.era THEN + ASSERT(x.era = wr.era, 23); + IF x.isElem THEN wr.WriteSChar(link) ELSE wr.WriteSChar(newlink) END; + wr.WriteInt(x.id); + wr.WriteInt(0); (* *) + wr.st.linkpos := wr.Pos(); + wr.WriteInt(0) (* *) + ELSE + x.era := wr.era; + WITH x: Alien DO + IF x.isElem THEN + wr.WriteSChar(elem); x.id := wr.nextElemId; INC(wr.nextElemId) + ELSE + wr.WriteSChar(store); x.id := wr.nextStoreId; INC(wr.nextStoreId) + END; + WritePath(wr, x.path) + ELSE + t := Kernel.TypeOf(x); + x.isElem := t.base[1] = wr.modelType; + IF x.isElem THEN + wr.WriteSChar(elem); x.id := wr.nextElemId; INC(wr.nextElemId) + ELSE + wr.WriteSChar(store); x.id := wr.nextStoreId; INC(wr.nextStoreId) + END; + WriteType(wr, t) + END; + wr.WriteInt(0); (* *) + pos1 := wr.Pos(); wr.WriteInt(0); wr.WriteInt(0); (* , *) + pos2 := wr.Pos(); wr.WriteInt(0); (* *) + save := wr.st; (* push current writer state; switch to structured *) + wr.st.linkpos := pos1 + 4; + WITH x: Alien DO ExternalizeAlien(wr, x.file, x.comps) + ELSE + x.Externalize(wr) + END; + wr.st := save; (* pop writer state *) + wr.st.linkpos := pos1; + pos := wr.Pos(); + wr.SetPos(pos2); wr.WriteInt(pos - pos2 - 4); (* patch *) + wr.SetPos(pos) + END; + wr.writtenStore := x + END WriteStore; + + + (** miscellaneous **) + + PROCEDURE Report* (IN msg, p0, p1, p2: ARRAY OF CHAR); + BEGIN + IF logReports THEN + Dialog.ShowParamMsg(msg, p0, p1, p2) + END + END Report; + + PROCEDURE BeginCloning (d: Domain); + BEGIN + ASSERT(d # NIL, 20); + INC(d.level); + IF d.level = 1 THEN + d.copyera := nextEra; INC(nextEra); d.nextElemId := 0; + IF d.cleaner = NIL THEN NEW(d.cleaner); d.cleaner.d := d END; + Kernel.PushTrapCleaner(d.cleaner) + END + END BeginCloning; + + PROCEDURE EndCloning (d: Domain); + BEGIN + ASSERT(d # NIL, 20); + DEC(d.level); + IF d.level = 0 THEN + d.sDict := NIL; + Kernel.PopTrapCleaner(d.cleaner); + d.s := NIL + END + END EndCloning; + + PROCEDURE CopyOf* (s: Store): Store; + VAR h: Store; c: StoreDict; d: Domain; k, org: INTEGER; + BEGIN + ASSERT(s # NIL, 20); + + d := DomainOf(s); + IF d = NIL THEN d := NewDomain(anonymousDomain); s.dlink := d; d.copyDomain := TRUE END; + + BeginCloning(d); + IF s.era >= d.copyera THEN (* s has already been copied *) + ASSERT(s.era = d.copyera, 21); + k := s.id MOD dictLineLen; org := s.id - k; + c := d.sDict; + WHILE (c # NIL) & (c.org # org) DO c := c.next END; + ASSERT((c # NIL) & (c.elem[k] # NIL), 100); + h := c.elem[k] + ELSE + s.era := d.copyera; + s.id := d.nextElemId; INC(d.nextElemId); + Kernel.NewObj(h, Kernel.TypeOf(s)); + k := s.id MOD dictLineLen; + IF k = 0 THEN NEW(c); c.org := s.id; c.next := d.sDict; d.sDict := c + ELSE c := d.sDict + END; + ASSERT((c # NIL) & (c.org = s.id - k) & (c.elem[k] = NIL), 101); + c.elem[k] := h; + IF d.s = NIL THEN d.s := h ELSE Join(h, d.s) END; + h.CopyFrom(s) + END; + EndCloning(d); + RETURN h + END CopyOf; + + PROCEDURE ExternalizeProxy* (s: Store): Store; + BEGIN + IF s # NIL THEN s.ExternalizeAs(s) END; + RETURN s + END ExternalizeProxy; + + PROCEDURE InitDomain* (s: Store); + VAR d: Domain; + BEGIN + ASSERT(s # NIL, 20); + d := DomainOf(s); + IF d = NIL THEN d := NewDomain(inited); s.dlink := d + ELSE d.initialized := TRUE + END + END InitDomain; + + PROCEDURE Join* (s0, s1: Store); + VAR d0, d1: Domain; + BEGIN + ASSERT(s0 # NIL, 20); ASSERT(s1 # NIL, 21); + d0 := DomainOf(s0); d1 := DomainOf(s1); + IF (d0 = NIL) & (d1 = NIL) THEN + s0.dlink := NewDomain(anonymousDomain); s1.dlink := s0.dlink + ELSIF d0 = NIL THEN + s0.dlink := d1; d1.copyDomain := FALSE + ELSIF d1 = NIL THEN + s1.dlink := d0; d0.copyDomain := FALSE + ELSIF d0 # d1 THEN + ASSERT(~d0.initialized OR ~d1.initialized, 22); + (* PRE 22 s0.Domain() = NIL OR s1.Domain() = NIL OR s0.Domain() = s1.Domain() *) + IF ~d0.initialized & (d0.level = 0) THEN d0.dlink := d1; d1.copyDomain := FALSE + ELSIF ~d1.initialized & (d1.level = 0) THEN d1.dlink := d0; d0.copyDomain := FALSE + ELSE HALT(100) + END + END + END Join; + + PROCEDURE Joined* (s0, s1: Store): BOOLEAN; + VAR d0, d1: Domain; + BEGIN + ASSERT(s0 # NIL, 20); ASSERT(s1 # NIL, 21); + d0 := DomainOf(s0); d1 := DomainOf(s1); + RETURN (s0 = s1) OR ((d0 = d1) & (d0 # NIL)) + END Joined; + + PROCEDURE Unattached* (s: Store): BOOLEAN; + BEGIN + ASSERT(s # NIL, 20); + RETURN (s.dlink = NIL) OR s.dlink.copyDomain + END Unattached; + +BEGIN + nextEra := 1; logReports := FALSE +END Stores. diff --git a/Trurl-based/System/Mod/Strings.txt b/Trurl-based/System/Mod/Strings.txt new file mode 100644 index 0000000..f675044 --- /dev/null +++ b/Trurl-based/System/Mod/Strings.txt @@ -0,0 +1,565 @@ +MODULE Strings; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Strings.txt *) + (* DO NOT EDIT *) + + IMPORT Math; + + CONST + charCode* = -1; decimal* = 10; hexadecimal* = -2; roman*= -3; + digitspace* = 08FX; + showBase* = TRUE; hideBase* = FALSE; + minLongIntRev = "8085774586302733229"; (* reversed string of -MIN(LONGINT) *) + + VAR + maxExp: INTEGER; + maxDig: INTEGER; + factor: REAL; (* 10^maxDig *) + digits: ARRAY 17 OF CHAR; + toUpper, toLower: ARRAY 256 OF CHAR; + + + (* integer conversions *) + + PROCEDURE IntToString* (x: LONGINT; OUT s: ARRAY OF CHAR); + VAR j, k: INTEGER; ch: CHAR; a: ARRAY 32 OF CHAR; + BEGIN + IF x # MIN(LONGINT) THEN + IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 + ELSE + a := minLongIntRev; s[0] := "-"; k := 1; + j := 0; WHILE a[j] # 0X DO INC(j) END + END; + ASSERT(k + j < LEN(s), 23); + REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X + END IntToString; + + PROCEDURE IntToStringForm* (x: LONGINT; form, minWidth: INTEGER; fillCh: CHAR; + showBase: BOOLEAN; OUT s: ARRAY OF CHAR); + VAR base, i, j, k, si: INTEGER; mSign: BOOLEAN; a: ARRAY 128 OF CHAR; c1, c5, c10: CHAR; + BEGIN + ASSERT((form = charCode) OR (form = hexadecimal) OR (form = roman) OR ((form >= 2) & (form <= 16)), 20); + ASSERT(minWidth >= 0, 22); + IF form = charCode THEN base := 16 + ELSIF form = hexadecimal THEN base := 16 + ELSE base := form + END; + + IF form = roman THEN + ASSERT((x > 0) & (x < 3999), 21); + base := 1000; i := 0; mSign := FALSE; + WHILE (base > 0) & (x > 0) DO + IF base = 1 THEN c1 := "I"; c5 := "V"; c10 := "X" + ELSIF base = 10 THEN c1 := "X"; c5 := "L"; c10 := "C" + ELSIF base = 100 THEN c1 := "C"; c5 := "D"; c10 := "M" + ELSE c1 := "M" + END; + k := SHORT(x DIV base); x := x MOD base; + IF k IN {4, 9} THEN a[i] := c1; INC(i) END; + IF k IN {4 .. 8} THEN a[i] := c5; INC(i) END; + IF k = 9 THEN a[i] := c10; INC(i) + ELSIF k IN {1 .. 3, 6 .. 8} THEN + j := k MOD 5; + REPEAT a[i] := c1; INC(i); DEC(j) UNTIL j = 0 + END; + base := base DIV 10 + END + ELSIF (form = hexadecimal) OR (form = charCode) THEN + i := 0; mSign := FALSE; + IF showBase THEN DEC(minWidth) END; + REPEAT + a[i] := digits[x MOD base]; x := x DIV base; INC(i) + UNTIL (x = 0) OR (x = -1) OR (i = LEN(a)); + IF x = -1 THEN fillCh := "F" END + ELSE + IF x < 0 THEN + i := 0; mSign := TRUE; DEC(minWidth); + REPEAT + IF x MOD base = 0 THEN + a[i] := digits[0]; x := x DIV base + ELSE + a[i] := digits[base - x MOD base]; x := x DIV base + 1 + END; + INC(i) + UNTIL (x = 0) OR (i = LEN(a)) + ELSE + i := 0; mSign := FALSE; + REPEAT + a[i] := digits[x MOD base]; x := x DIV base; INC(i) + UNTIL (x = 0) OR (i = LEN(a)) + END; + IF showBase THEN DEC(minWidth); + IF base < 10 THEN DEC(minWidth) ELSE DEC(minWidth,2) END + END + END; + si := 0; + IF mSign & (fillCh = "0") & (si < LEN(s)) THEN s[si] := "-"; INC(si); mSign := FALSE END; + WHILE minWidth > i DO + IF si < LEN(s) THEN s[si] := fillCh; INC(si) END; + DEC(minWidth) + END; + IF mSign & (si < LEN(s)) THEN s[si] := "-"; INC(si) END; + IF form = roman THEN + j := 0; + WHILE j < i DO + IF si < LEN(s) THEN s[si] := a[j]; INC(si) END; + INC(j) + END + ELSE + REPEAT DEC(i); + IF si < LEN(s) THEN s[si] := a[i]; INC(si) END + UNTIL i = 0 + END; + IF showBase & (form # roman) THEN + IF (form = charCode) & (si < LEN(s)) THEN s[si] := "X"; INC(si) + ELSIF (form = hexadecimal) & (si < LEN(s)) THEN s[si] := "H"; INC(si) + ELSIF (form < 10) & (si < LEN(s)-1) THEN s[si] := "%"; s[si+1] := digits[base]; INC(si, 2) + ELSIF (si < LEN(s) - 2) THEN + s[si] := "%"; s[si+1] := digits[base DIV 10]; s[si+2] := digits[base MOD 10]; INC(si, 3) + END + END; + IF si < LEN(s) THEN s[si] := 0X ELSE HALT(23) END + END IntToStringForm; + + PROCEDURE StringToInt* (IN s: ARRAY OF CHAR; OUT x: INTEGER; OUT res: INTEGER); + CONST hexLimit = MAX(INTEGER) DIV 8 + 1; + VAR i, j, k, digits: INTEGER; ch, top: CHAR; neg: BOOLEAN; base: INTEGER; + BEGIN + res := 0; i := 0; ch := s[0]; + WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO (* ignore leading blanks *) + INC(i); ch := s[i] + END; + j := i; top := "0"; + WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO + IF ch > top THEN top := ch END; + INC(j); ch := s[j] + END; + IF (ch = "H") OR (ch = "X") THEN + x := 0; ch := s[i]; + IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN + WHILE ch = "0" DO INC(i); ch := s[i] END; + digits := 0; + WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO + IF ch < "A" THEN k := ORD(ch) - ORD("0") + ELSE k := ORD(ch) - ORD("A") + 10 + END; + IF digits < 8 THEN + x := x MOD hexLimit; + IF x >= hexLimit DIV 2 THEN x := x - hexLimit END; + x := x * 16 + k; INC(i); ch := s[i] + ELSE res := 1 + END; + INC(digits) + END; + IF res = 0 THEN + IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END + END + ELSE res := 2 + END + ELSE + IF ch = "%" THEN + INC(j); ch := s[j]; base := 0; + IF ("0" <= ch) & (ch <= "9") THEN + k := ORD(ch) - ORD("0"); + REPEAT + base := base * 10 + k; + INC(j); ch := s[j]; k := ORD(ch) - ORD("0") + UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(INTEGER) - k) DIV 10); + IF ("0" <= ch) & (ch <= "9") THEN base := 0 END + END + ELSE + base := 10 + END; + + IF (base < 2) OR (base > 16) THEN + res := 2 + ELSIF (base <= 10) & (ORD(top) < base + ORD("0")) + OR (base > 10) & (ORD(top) < base - 10 + ORD("A")) THEN + x := 0; ch := s[i]; neg := FALSE; + IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; + IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN + IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END; + WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO + IF x >= (MIN(INTEGER) + (base - 1) + k) DIV base THEN + x := x * base - k; INC(i); ch := s[i]; + IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END + ELSE res := 1 + END + END + ELSE res := 2 + END; + IF res = 0 THEN + IF ~neg THEN + IF x > MIN(INTEGER) THEN x := -x ELSE res := 1 END + END; + IF (ch # 0X) & (ch # "%") THEN res := 2 END + END + ELSE + res := 2 + END + END + END StringToInt; + + PROCEDURE StringToLInt* (IN s: ARRAY OF CHAR; OUT x: LONGINT; OUT res: INTEGER); + CONST hexLimit = MAX(LONGINT) DIV 8 + 1; + VAR i, j, k, digits: INTEGER; ch, top: CHAR; neg: BOOLEAN; base: INTEGER; + BEGIN + res := 0; i := 0; ch := s[0]; + WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO (* ignore leading blanks *) + INC(i); ch := s[i] + END; + j := i; top := "0"; + WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO + IF ch > top THEN top := ch END; + INC(j); ch := s[j] + END; + IF (ch = "H") OR (ch = "X") THEN + x := 0; ch := s[i]; + IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN + WHILE ch = "0" DO INC(i); ch := s[i] END; + digits := 0; + WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO + IF ch < "A" THEN k := ORD(ch) - ORD("0") + ELSE k := ORD(ch) - ORD("A") + 10 + END; + IF digits < 16 THEN + x := x MOD hexLimit; + IF x >= hexLimit DIV 2 THEN x := x - hexLimit END; + x := x * 16 + k; INC(i); ch := s[i] + ELSE res := 1 + END; + INC(digits) + END; + IF res = 0 THEN + IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END + END + ELSE res := 2 + END + ELSE + IF ch = "%" THEN + INC(j); ch := s[j]; base := 0; + IF ("0" <= ch) & (ch <= "9") THEN + k := ORD(ch) - ORD("0"); + REPEAT + base := base * 10 + k; + INC(j); ch := s[j]; k := ORD(ch) - ORD("0") + UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(INTEGER) - k) DIV 10); + IF ("0" <= ch) & (ch <= "9") THEN base := 0 END + END + ELSE + base := 10 + END; + + IF (base < 2) OR (base > 16) THEN + res := 2 + ELSIF (base <= 10) & (ORD(top) < base + ORD("0")) + OR (base > 10) & (ORD(top) < base -10 + ORD("A")) THEN + x := 0; ch := s[i]; neg := FALSE; + IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END; + IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN + IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END; + WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO + IF x >= (MIN(LONGINT) + (base - 1) + k) DIV base THEN + x := x * base - k; INC(i); ch := s[i]; + IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END + ELSE res := 1 + END + END + ELSE res := 2 + END; + IF res = 0 THEN + IF ~neg THEN + IF x > MIN(LONGINT) THEN x := -x ELSE res := 1 END + END; + IF (ch # 0X) & (ch # "%") THEN res := 2 END + END + ELSE + res := 2 + END + END + END StringToLInt; + + + (* real conversions *) + + PROCEDURE RealToStringForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR; + OUT s: ARRAY OF CHAR); + VAR exp, len, i, j, n, k, p: INTEGER; m: ARRAY 80 OF CHAR; neg: BOOLEAN; + BEGIN + ASSERT((precision > 0) (*& (precision <= 18)*), 20); + ASSERT((minW >= 0) & (minW < LEN(s)), 21); + ASSERT((expW > -LEN(s)) & (expW <= 3), 22); + exp := Math.Exponent(x); + IF exp = MAX(INTEGER) THEN + IF fillCh = "0" THEN fillCh := digitspace END; + x := Math.Mantissa(x); + IF x = -1 THEN m := "-inf"; n := 4 + ELSIF x = 1 THEN m := "inf"; n := 3 + ELSE m := "nan"; n := 3 + END; + i := 0; j := 0; + WHILE minW > n DO s[i] := fillCh; INC(i); DEC(minW) END; + WHILE (j <= n) & (i < LEN(s)) DO s[i] := m[j]; INC(i); INC(j) END + ELSE + neg := FALSE; len := 1; m := "00"; + IF x < 0 THEN x := -x; neg := TRUE; DEC(minW) END; + IF x # 0 THEN + exp := (exp - 8) * 30103 DIV 100000; (* * log(2) *) + IF exp > 0 THEN + n := SHORT(ENTIER(x / Math.IntPower(10, exp))); + x := x / Math.IntPower(10, exp) - n + ELSIF exp > -maxExp THEN + n := SHORT(ENTIER(x * Math.IntPower(10, -exp))); + x := x * Math.IntPower(10, -exp) - n + ELSE + n := SHORT(ENTIER(x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor)); + x := x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor - n + END; + (* x0 = (n + x) * 10^exp, 200 < n < 5000 *) + p := precision - 4; + IF n < 1000 THEN INC(p) END; + IF (expW < 0) & (p > exp - expW) THEN p := exp - expW END; + IF p >= 0 THEN + x := x + 0.5 / Math.IntPower(10, p); (* rounding correction *) + IF x >= 1 THEN INC(n); x := x - 1 END + ELSIF p = -1 THEN INC(n, 5) + ELSIF p = -2 THEN INC(n, 50) + ELSIF p = -3 THEN INC(n, 500) + END; + i := 0; k := 1000; INC(exp, 3); + IF n < 1000 THEN k := 100; DEC(exp) END; + WHILE (i < precision) & ((k > 0) OR (x # 0)) DO + IF k > 0 THEN p := n DIV k; n := n MOD k; k := k DIV 10 + ELSE x := x * 10; p := SHORT(ENTIER(x)); x := x - p + END; + m[i] := CHR(p + ORD("0")); INC(i); + IF p # 0 THEN len := i END + END + END; + (* x0 = m[0].m[1]...m[len-1] * 10^exp *) + i := 0; + IF (expW < 0) OR (expW = 0) & (exp >= -3) & (exp <= len + 1) THEN + n := exp + 1; k := len - n; + IF n < 1 THEN n := 1 END; + IF expW < 0 THEN k := -expW ELSIF k < 1 THEN k := 1 END; + j := minW - n - k - 1; p := -exp; + IF neg & (p >= MAX(0, n) + MAX(0, k)) THEN neg := FALSE; INC(j) END + ELSE + IF ABS(exp) >= 100 THEN expW := 3 + ELSIF (expW < 2) & (ABS(exp) >= 10) THEN expW := 2 + ELSIF expW < 1 THEN expW := 1 + END; + IF len < 2 THEN len := 2 END; + j := minW - len - 3 - expW; k := len; + IF j > 0 THEN + k := k + j; j := 0; + IF k > precision THEN j := k - precision; k := precision END + END; + n := 1; DEC(k); p := 0 + END; + IF neg & (fillCh = "0") THEN s[i] := "-"; INC(i); neg := FALSE END; + WHILE j > 0 DO s[i] := fillCh; INC(i); DEC(j) END; + IF neg & (i < LEN(s)) THEN s[i] := "-"; INC(i) END; + j := 0; + WHILE (n > 0) & (i < LEN(s)) DO + IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END; + INC(i); DEC(n); DEC(p) + END; + IF i < LEN(s) THEN s[i] := "."; INC(i) END; + WHILE (k > 0) & (i < LEN(s)) DO + IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END; + INC(i); DEC(k); DEC(p) + END; + IF expW > 0 THEN + IF i < LEN(s) THEN s[i] := "E"; INC(i) END; + IF i < LEN(s) THEN + IF exp < 0 THEN s[i] := "-"; exp := -exp ELSE s[i] := "+" END; + INC(i) + END; + IF (expW = 3) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 100 + ORD("0")); INC(i) END; + IF (expW >= 2) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 10 MOD 10 + ORD("0")); INC(i) END; + IF i < LEN(s) THEN s[i] := CHR(exp MOD 10 + ORD("0")); INC(i) END + END + END; + IF i < LEN(s) THEN s[i] := 0X ELSE HALT(23) END + END RealToStringForm; + + PROCEDURE RealToString* (x: REAL; OUT s: ARRAY OF CHAR); + BEGIN + RealToStringForm(x, 16, 0, 0, digitspace, s) + END RealToString; + + + PROCEDURE StringToReal* (IN s: ARRAY OF CHAR; OUT x: REAL; OUT res: INTEGER); + VAR first, last, point, e, n, i, exp: INTEGER; y: REAL; ch: CHAR; neg, negExp, dig: BOOLEAN; + BEGIN + res := 0; i := 0; ch := s[0]; dig := FALSE; + WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO INC(i); ch := s[i] END; + IF ch = "+" THEN + neg := FALSE; INC(i); ch := s[i] + ELSIF ch = "-" THEN + neg := TRUE; INC(i); ch := s[i] + ELSE + neg := FALSE + END; + WHILE ch = "0" DO INC(i); ch := s[i]; dig := TRUE END; + first := i; e := 0; + WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; INC(e); dig := TRUE END; + point := i; + IF ch = "." THEN + INC(i); ch := s[i]; + IF e = 0 THEN + WHILE ch = "0" DO INC(i); ch := s[i]; DEC(e); dig := TRUE END; + first := i + END; + WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; dig := TRUE END + END; + last := i - 1; exp := 0; + IF (ch = "E") OR (ch = "D") THEN + INC(i); ch := s[i]; negExp := FALSE; + IF ch = "-" THEN negExp := TRUE; INC(i); ch := s[i] + ELSIF ch = "+" THEN INC(i); ch := s[i] + END; + WHILE ("0" <= ch) & (ch <= "9") & (exp < 1000) DO + exp := exp * 10 + (ORD(ch) - ORD("0")); + INC(i); ch := s[i] + END; + IF negExp THEN exp := -exp END + END; + exp := exp + e; x := 0; y := 0; n := 0; + WHILE (n < maxDig) & (first <= last) DO + IF first # point THEN x := x * 10 + (ORD(s[first]) - ORD("0")); INC(n) END; + INC(first) + END; + WHILE last >= first DO + IF last # point THEN y := (y + (ORD(s[last]) - ORD("0"))) / 10 END; + DEC(last) + END; + IF ~dig OR (ch # 0X) THEN res := 2 (* syntax error *) + ELSIF exp < -maxExp - maxDig THEN + x := 0.0 + ELSIF exp < -maxExp + maxDig THEN + x := (x + y) / Math.IntPower(10, n - exp - 2 * maxDig) / factor / factor + ELSIF exp < n THEN + x := (x + y) / Math.IntPower(10, n - exp) + ELSIF exp < maxExp THEN + x := (x + y) * Math.IntPower(10, exp - n) + ELSIF exp = maxExp THEN + x := (x + y) * (Math.IntPower(10, exp - n) / 16); + IF x <= MAX(REAL) / 16 THEN x := x * 16 + ELSE res := 1 (* overflow *) + END + ELSE res := 1 (* overflow *) + END; + IF neg THEN x := -x END + END StringToReal; + + (* ----------------------------- string manipulation routines --------------------------- *) + + PROCEDURE Valid* (IN s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + BEGIN i := 0; + WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END; + RETURN i < LEN(s) + END Valid; + + PROCEDURE Upper* (ch: CHAR): CHAR; + BEGIN + IF ORD(ch) < 256 THEN RETURN toUpper[ORD(ch)] ELSE RETURN ch END + END Upper; + + PROCEDURE ToUpper* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + VAR i, max: INTEGER; + BEGIN i := 0; max := LEN(out)-1; + WHILE (in[i] # 0X) & (i < max) DO + IF ORD(in[i]) < 256 THEN out[i] := toUpper[ORD(in[i])] ELSE out[i] := in[i] END; + INC(i) + END; + out[i] := 0X + END ToUpper; + + PROCEDURE Lower* (ch: CHAR): CHAR; + BEGIN + IF ORD(ch) < 256 THEN RETURN toLower[ORD(ch)] ELSE RETURN ch END + END Lower; + + PROCEDURE ToLower* (in: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + VAR i, max: INTEGER; + BEGIN i := 0; max := LEN(out)-1; + WHILE (in[i] # 0X) & (i < max) DO + IF ORD(in[i]) < 256 THEN out[i] := toLower[ORD(in[i])] ELSE out[i] := in[i] END; + INC(i) + END; + out[i] := 0X + END ToLower; + + PROCEDURE Replace* (VAR s: ARRAY OF CHAR; pos, len: INTEGER; IN rep: ARRAY OF CHAR); + (* replace stretch s[pos]..s[pos+len-1] with rep *) + (* insert semantics if len = 0; delete semantics if Len(rep) = 0 *) + VAR i, j, k, max, lenS: INTEGER; ch: CHAR; + BEGIN + ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21); + lenS := LEN(s$); max := LEN(s) - 1; + IF pos <= lenS THEN i := pos; j := 0; + IF pos+len > lenS THEN len := lenS - pos END; + WHILE (rep[j] # 0X) & (len > 0) DO + s[i] := rep[j]; INC(i); INC(j); DEC(len) + END; + IF len > 0 THEN (* delete the remaining part of the stretch [pos, pos+len) *) + REPEAT ch := s[i+len]; s[i] := ch; INC(i) UNTIL ch = 0X + ELSE (* insert the remaining part of rep *) + len := LEN(rep$) - j; k := lenS + len; + IF k > max THEN k := max END; + s[k] := 0X; + WHILE k - len >= i DO s[k] := s[k-len]; DEC(k) END; + WHILE (rep[j] # 0X) & (i < max) DO s[i] := rep[j]; INC(i); INC(j) END + END + END + END Replace; + + PROCEDURE Extract* (s: ARRAY OF CHAR; pos, len: INTEGER; OUT res: ARRAY OF CHAR); + VAR i, j, max: INTEGER; + BEGIN + ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21); + i := 0; j := 0; max := LEN(res) - 1; + WHILE (i < pos) & (s[i] # 0X) DO INC(i) END; + WHILE (j < len) & (j < max) & (s[i] # 0X) DO res[j] := s[i]; INC(j); INC(i) END; + res[j] := 0X + END Extract; + + PROCEDURE Find* (IN s: ARRAY OF CHAR; IN pat: ARRAY OF CHAR; start: INTEGER; OUT pos: INTEGER); + VAR j: INTEGER; + BEGIN + ASSERT(start >= 0, 20); + IF (start = 0) OR (start <= LEN(s$) - LEN(pat$)) THEN + (* start = 0 is optimization: need not call Len *) + pos := start; + WHILE s[pos] # 0X DO j := 0; + WHILE (s[pos+j] = pat[j]) & (pat[j] # 0X) DO INC(j) END; + IF pat[j] = 0X THEN RETURN END; + INC(pos) + END + END; + pos := -1 (* pattern not found *) + END Find; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN + FOR i := 0 TO 255 DO toUpper[i] := CHR(i); toLower[i] := CHR(i) END; + FOR i := ORD("A") TO ORD("Z") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END; + FOR i := ORD("À") TO ORD ("Ö") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END; + FOR i := ORD("Ø") TO ORD ("Þ") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END; + digits := "0123456789ABCDEF"; + maxExp := SHORT(ENTIER(Math.Log(MAX(REAL)))) + 1; + maxDig := SHORT(ENTIER(-Math.Log(Math.Eps()))); + factor := Math.IntPower(10, maxDig) + END Init; + +BEGIN + Init +END Strings. diff --git a/Trurl-based/System/Mod/Views.txt b/Trurl-based/System/Mod/Views.txt new file mode 100644 index 0000000..f3a2294 --- /dev/null +++ b/Trurl-based/System/Mod/Views.txt @@ -0,0 +1,1347 @@ +MODULE Views; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Views.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, + Kernel, Log, Dialog, Files, Services, Fonts, Stores, Converters, Ports, Sequencers, Models; + + CONST + (** View.Background color **) + transparent* = 0FF000000H; + + (** Views.CopyModel / Views.CopyOf shallow **) + deep* = FALSE; shallow* = TRUE; + + (** Update, UpdateIn rebuild **) + keepFrames* = FALSE; rebuildFrames* = TRUE; + + (** Deposit, QualifiedDeposit, Fetch w, h **) + undefined* = 0; + + (** OldView, RegisterView ask **) + dontAsk* = FALSE; ask* = TRUE; + + (* method numbers (UNSAFE!) *) + (* copyFrom = 1; *) + copyFromModelView = 7; copyFromSimpleView = 8; + + (* Frame.state *) + new = 0; open = 1; closed = 2; + + maxN = 30; (* max number of rects used to approximate a region *) + + minVersion = 0; maxVersion = 0; + + (* actOp *) + handler = 1; restore = 2; externalize = 3; + + markBorderSize = 2; + + clean* = Sequencers.clean; + notUndoable* = Sequencers.notUndoable; + invisible* = Sequencers.invisible; + + + TYPE + + (** views **) + + View* = POINTER TO ABSTRACT RECORD (Stores.Store) + context-: Models.Context; (** stable context # NIL **) + era: INTEGER; + guard: INTEGER; (* = TrapCount()+1 if view is addressee of ongoing broadcast *) + bad: SET + END; + + Alien* = POINTER TO LIMITED RECORD (View) + store-: Stores.Alien + END; + + Title* = ARRAY 64 OF CHAR; + + TrapAlien = POINTER TO RECORD (Stores.Store) END; + + + (** frames **) + + Frame* = POINTER TO ABSTRACT RECORD (Ports.Frame) + l-, t-, r-, b-: INTEGER; (** l < r, t < b **) + view-: View; (** opened => view # NIL, view.context # NIL, view.seq # NIL **) + front-, mark-: BOOLEAN; + state: BYTE; + x, y: INTEGER; (* origin in coordinates of environment *) + gx0, gy0: INTEGER; (* global origin w/o local scrolling compensation *) + sx, sy: INTEGER; (* cumulated local sub-pixel scrolling compensation *) + next, down, up, focus: Frame; + level: INTEGER (* used for partial z-ordering *) + END; + + + Message* = ABSTRACT RECORD + view-: View (** view # NIL **) + END; + + NotifyMsg* = EXTENSIBLE RECORD (Message) + id0*, id1*: INTEGER; + opts*: SET + END; + + NotifyHook = POINTER TO RECORD (Dialog.NotifyHook) END; + + UpdateCachesMsg* = EXTENSIBLE RECORD (Message) END; + + ScrollClassMsg* = RECORD (Message) + allowBitmapScrolling*: BOOLEAN (** OUT, preset to FALSE **) + END; + + + (** property messages **) + + PropMessage* = ABSTRACT RECORD END; + + + (** controller messages **) + + CtrlMessage* = ABSTRACT RECORD END; + + CtrlMsgHandler* = PROCEDURE (op: INTEGER; f, g: Frame; VAR msg: CtrlMessage; VAR mark, front, req: BOOLEAN); + + UpdateMsg = RECORD (Message) + scroll, rebuild, all: BOOLEAN; + l, t, r, b, dx, dy: INTEGER + END; + + + Rect = RECORD + v: View; + rebuild: BOOLEAN; + l, t, r, b: INTEGER + END; + + Region = POINTER TO RECORD + n: INTEGER; + r: ARRAY maxN OF Rect + END; + + RootFrame* = POINTER TO RECORD (Frame) + flags-: SET; + update: Region (* allocated lazily by SetRoot *) + END; + + StdFrame = POINTER TO RECORD (Frame) END; + + + (* view producer/consumer decoupling *) + + QueueElem = POINTER TO RECORD + next: QueueElem; + view: View + END; + + GetSpecHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + ViewHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + MsgHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END; + + + + VAR + HandleCtrlMsg-: CtrlMsgHandler; + + domainGuard: INTEGER; (* = TrapCount()+1 if domain is addressee of ongoing domaincast *) + + actView: View; + actFrame: RootFrame; + actOp: INTEGER; + + copyModel: Models.Model; (* context for (View)CopyFrom; reset by TrapCleanup *) + + queue: RECORD + len: INTEGER; + head, tail: QueueElem + END; + + getSpecHook: GetSpecHook; + viewHook: ViewHook; + msgHook: MsgHook; + + + PROCEDURE Overwritten (v: View; mno: INTEGER): BOOLEAN; + VAR base, actual: PROCEDURE; + BEGIN + SYSTEM.GET(SYSTEM.TYP(View) - 4 * (mno + 1), base); + SYSTEM.GET(SYSTEM.TYP(v) - 4 * (mno + 1), actual); + RETURN actual # base + END Overwritten; + + (** Hooks **) + + PROCEDURE (h: GetSpecHook) GetExtSpec* (s: Stores.Store; VAR loc: Files.Locator; + VAR name: Files.Name; VAR conv: Converters.Converter), NEW, ABSTRACT; + PROCEDURE (h: GetSpecHook) GetIntSpec* (VAR loc: Files.Locator; VAR name: Files.Name; + VAR conv: Converters.Converter), NEW, ABSTRACT; + + PROCEDURE SetGetSpecHook*(h: GetSpecHook); + BEGIN + getSpecHook := h + END SetGetSpecHook; + + PROCEDURE (h: ViewHook) OldView* (loc: Files.Locator; name: Files.Name; + VAR conv: Converters.Converter): View, NEW, ABSTRACT; + PROCEDURE (h: ViewHook) Open* (s: View; title: ARRAY OF CHAR; + loc: Files.Locator; name: Files.Name; conv: Converters.Converter; + asTool, asAux, noResize, allowDuplicates, neverDirty: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (h: ViewHook) RegisterView* (s: View; loc: Files.Locator; + name: Files.Name; conv: Converters.Converter), NEW, ABSTRACT; + + PROCEDURE SetViewHook*(h: ViewHook); + BEGIN + viewHook := h + END SetViewHook; + + PROCEDURE (h: MsgHook) Omnicast* (VAR msg: ANYREC), NEW, ABSTRACT; + PROCEDURE (h: MsgHook) RestoreDomain* (domain: Stores.Domain), NEW, ABSTRACT; + + PROCEDURE SetMsgHook*(h: MsgHook); + BEGIN + msgHook := h + END SetMsgHook; + + + (** Model protocol **) + + PROCEDURE (v: View) CopyFromSimpleView- (source: View), NEW, EMPTY; + PROCEDURE (v: View) CopyFromModelView- (source: View; model: Models.Model), NEW, EMPTY; + + PROCEDURE (v: View) ThisModel* (): Models.Model, NEW, EXTENSIBLE; + BEGIN + RETURN NIL + END ThisModel; + + + (** Store protocol **) + + PROCEDURE (v: View) CopyFrom- (source: Stores.Store); + VAR tm, fm: Models.Model; c: Models.Context; + BEGIN + tm := copyModel; copyModel := NIL; + WITH source: View DO + v.era := source.era; + actView := NIL; + IF tm = NIL THEN (* if copyModel wasn't preset then use deep copy as default *) + fm := source.ThisModel(); + IF fm # NIL THEN tm := Stores.CopyOf(fm)(Models.Model) END + END; + actView := v; + IF Overwritten(v, copyFromModelView) THEN (* new View *) + ASSERT(~Overwritten(v, copyFromSimpleView), 20); + c := v.context; + v.CopyFromModelView(source, tm); + ASSERT(v.context = c, 60) + ELSE (* old or simple View *) + (* IF tm # NIL THEN v.InitModel(tm) END *) + c := v.context; + v.CopyFromSimpleView(source); + ASSERT(v.context = c, 60) + END + END + END CopyFrom; + + PROCEDURE (v: View) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion) + END Internalize; + + PROCEDURE (v: View) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + v.Externalize^(wr); + wr.WriteVersion(maxVersion) + END Externalize; + + + (** embedding protocol **) + + PROCEDURE (v: View) InitContext* (context: Models.Context), NEW, EXTENSIBLE; + BEGIN + ASSERT(context # NIL, 21); + ASSERT((v.context = NIL) OR (v.context = context), 22); + v.context := context + END InitContext; + + PROCEDURE (v: View) GetBackground* (VAR color: Ports.Color), NEW, EMPTY; + PROCEDURE (v: View) ConsiderFocusRequestBy- (view: View), NEW, EMPTY; + PROCEDURE (v: View) Neutralize*, NEW, EMPTY; + + + (** Frame protocol **) + + PROCEDURE (v: View) GetNewFrame* (VAR frame: Frame), NEW, EMPTY; + PROCEDURE (v: View) Restore* (f: Frame; l, t, r, b: INTEGER), NEW, ABSTRACT; + PROCEDURE (v: View) RestoreMarks* (f: Frame; l, t, r, b: INTEGER), NEW, EMPTY; + + + (** handlers **) + + PROCEDURE (v: View) HandleModelMsg- (VAR msg: Models.Message), NEW, EMPTY; + PROCEDURE (v: View) HandleViewMsg- (f: Frame; VAR msg: Message), NEW, EMPTY; + PROCEDURE (v: View) HandleCtrlMsg* (f: Frame; VAR msg: CtrlMessage; VAR focus: View), NEW, EMPTY; + PROCEDURE (v: View) HandlePropMsg- (VAR msg: PropMessage), NEW, EMPTY; + + + (** Alien **) + + PROCEDURE (a: Alien) Externalize- (VAR wr: Stores.Writer); + BEGIN + HALT(100) + END Externalize; + + PROCEDURE (a: Alien) Internalize- (VAR rd: Stores.Reader); + BEGIN + HALT(100) + END Internalize; + + PROCEDURE (a: Alien) CopyFromSimpleView- (source: View); + BEGIN + a.store := Stores.CopyOf(source(Alien).store)(Stores.Alien); Stores.Join(a, a.store) + END CopyFromSimpleView; + + PROCEDURE (a: Alien) Restore* (f: Frame; l, t, r, b: INTEGER); + VAR u, w, h: INTEGER; + BEGIN + u := f.dot; a.context.GetSize(w, h); + f.DrawRect(0, 0, w, h, Ports.fill, Ports.grey25); + f.DrawRect(0, 0, w, h, 2 * u, Ports.grey75); + f.DrawLine(0, 0, w - u, h - u, u, Ports.grey75); + f.DrawLine(w - u, 0, 0, h - u, u, Ports.grey75) + END Restore; + + + (** TrapAlien **) + + PROCEDURE (v: TrapAlien) Internalize (VAR rd: Stores.Reader); + BEGIN + v.Internalize^(rd); + rd.TurnIntoAlien(3) + END Internalize; + + PROCEDURE (v: TrapAlien) Externalize (VAR rd: Stores.Writer); + END Externalize; + + PROCEDURE (v: TrapAlien) CopyFrom (source: Stores.Store), EMPTY; + + + (** Frame **) + + PROCEDURE (f: Frame) Close* (), NEW, EMPTY; + + + (* Rect, Region *) + + PROCEDURE Union (VAR u: Rect; r: Rect); + BEGIN + IF r.v # u.v THEN u.v := NIL END; + IF r.rebuild THEN u.rebuild := TRUE END; + IF r.l < u.l THEN u.l := r.l END; + IF r.t < u.t THEN u.t := r.t END; + IF r.r > u.r THEN u.r := r.r END; + IF r.b > u.b THEN u.b := r.b END + END Union; + + PROCEDURE Add (rgn: Region; v: View; rebuild: BOOLEAN; gl, gt, gr, gb: INTEGER); + (* does not perfectly maintain invariant of non-overlapping approx rects ... *) + VAR q: Rect; i, j, n: INTEGER; x: ARRAY maxN OF BOOLEAN; + BEGIN + q.v := v; q.rebuild := rebuild; q.l := gl; q.t := gt; q.r := gr; q.b := gb; + n := rgn.n + 1; + i := 0; + WHILE i < rgn.n DO + x[i] := (gl < rgn.r[i].r) & (rgn.r[i].l < gr) & (gt < rgn.r[i].b) & (rgn.r[i].t < gb); + IF x[i] THEN Union(q, rgn.r[i]); DEC(n) END; + INC(i) + END; + IF n > maxN THEN + (* n = maxN + 1 -> merge q with arbitrarily picked rect and Add *) + Union(q, rgn.r[maxN - 1]); Add(rgn, v, q.rebuild, q.l, q.t, q.r, q.b) + ELSE + i := 0; WHILE (i < rgn.n) & ~x[i] DO INC(i) END; + rgn.r[i] := q; INC(i); WHILE (i < rgn.n) & ~x[i] DO INC(i) END; + j := i; WHILE (i < rgn.n) & x[i] DO INC(i) END; + WHILE i < rgn.n DO (* ~x[i] *) + rgn.r[j] := rgn.r[i]; INC(j); INC(i); + WHILE (i < rgn.n) & x[i] DO INC(i) END + END; + rgn.n := n + END + END Add; + + PROCEDURE AddRect (root: RootFrame; f: Frame; l, t, r, b: INTEGER; rebuild: BOOLEAN); + VAR rl, rt, rr, rb: INTEGER; i: INTEGER; + BEGIN + INC(l, f.gx); INC(t, f.gy); INC(r, f.gx); INC(b, f.gy); + rl := root.l + root.gx; rt := root.t + root.gy; rr := root.r + root.gx; rb := root.b + root.gy; + IF l < rl THEN l := rl END; + IF t < rt THEN t := rt END; + IF r > rr THEN r := rr END; + IF b > rb THEN b := rb END; + IF (l < r) & (t < b) THEN + Add(root.update, f.view, rebuild, l, t, r, b); + i := 0; + WHILE (i < root.update.n) + & (~root.update.r[i].rebuild OR (root.update.r[i].v # NIL)) DO INC(i) END; + IF i < root.update.n THEN Add(root.update, root.view, TRUE, rl, rt, rr, rb) END + END + END AddRect; + + + (** miscellaneous **) + + PROCEDURE RestoreDomain* (domain: Stores.Domain); + BEGIN + ASSERT(msgHook # NIL, 100); + msgHook.RestoreDomain(domain) + END RestoreDomain; + + PROCEDURE MarkBorder* (host: Ports.Frame; view: View; l, t, r, b: INTEGER); + VAR s: INTEGER; + BEGIN + IF view # NIL THEN + s := markBorderSize * host.dot; + host.MarkRect(l - s, t - s, r + s, b + s, s, Ports.dim50, Ports.show) + END + END MarkBorder; + + + + (** views **) + + PROCEDURE SeqOf (v: View): Sequencers.Sequencer; + VAR (*c: Models.Context;*) d: Stores.Domain; seq: Sequencers.Sequencer; any: ANYPTR; + BEGIN + d := v.Domain(); seq := NIL; + IF d # NIL THEN + any := d.GetSequencer(); + IF (any # NIL) & (any IS Sequencers.Sequencer) THEN + seq := any(Sequencers.Sequencer) + END + END; + RETURN seq + END SeqOf; + + + PROCEDURE Era* (v: View): INTEGER; + (** pre: v # NIL *) + (** post: + v.ThisModel() # NIL + in-synch(v) iff Era(v) = Models.Era(v.ThisModel()) + **) + BEGIN + ASSERT(v # NIL, 20); + RETURN v.era + END Era; + + PROCEDURE BeginScript* (v: View; name: Stores.OpName; OUT script: Stores.Operation); + (** pre: v # NIL *) + (** post: (script # NIL) iff (v.seq # NIL) **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN seq.BeginScript(name, script) + ELSE script := NIL + END + END BeginScript; + + PROCEDURE Do* (v: View; name: Stores.OpName; op: Stores.Operation); + (** pre: v # NIL, op # NIL, ~op.inUse **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); ASSERT(op # NIL, 21); (* ASSERT(~op.inUse, 22); *) + seq := SeqOf(v); + IF seq # NIL THEN seq.Do(v, name, op) ELSE op.Do END + END Do; + + PROCEDURE LastOp* (v: View): Stores.Operation; + (** pre: v # NIL **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN RETURN seq.LastOp(v) ELSE RETURN NIL END + END LastOp; + + PROCEDURE Bunch* (v: View); + (** pre: v # NIL **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); ASSERT(seq # NIL, 21); + seq.Bunch(v) + END Bunch; + + PROCEDURE StopBunching* (v: View); + (** pre: v # NIL **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN seq.StopBunching END + END StopBunching; + + PROCEDURE EndScript* (v: View; script: Stores.Operation); + (** pre: (script # NIL) iff (v.seq # NIL) **) + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN ASSERT(script # NIL, 21); seq.EndScript(script) + ELSE ASSERT(script = NIL, 22) + END + END EndScript; + + + PROCEDURE BeginModification* (type: INTEGER; v: View); + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN seq.BeginModification(type, v) END + END BeginModification; + + PROCEDURE EndModification* (type: INTEGER; v: View); + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN seq.EndModification(type, v) END + END EndModification; + + PROCEDURE SetDirty* (v: View); + VAR seq: Sequencers.Sequencer; + BEGIN + ASSERT(v # NIL, 20); + seq := SeqOf(v); + IF seq # NIL THEN seq.SetDirty(TRUE) END + END SetDirty; + + + PROCEDURE Domaincast* (domain: Stores.Domain; VAR msg: Message); + VAR g: INTEGER; seq: ANYPTR; + BEGIN + IF domain # NIL THEN + seq := domain.GetSequencer(); + IF seq # NIL THEN + msg.view := NIL; + g := Kernel.trapCount + 1; + IF domainGuard > 0 THEN ASSERT(domainGuard # g, 20) END; + domainGuard := g; + seq(Sequencers.Sequencer).Handle(msg); + domainGuard := 0 + END + END + END Domaincast; + + PROCEDURE Broadcast* (v: View; VAR msg: Message); + VAR seq: Sequencers.Sequencer; g: INTEGER; + BEGIN + ASSERT(v # NIL, 20); + msg.view := v; + seq := SeqOf(v); + IF seq # NIL THEN + g := Kernel.trapCount + 1; + IF v.guard > 0 THEN ASSERT(v.guard # g, 21) END; + v.guard := g; + seq.Handle(msg); + v.guard := 0 + END + END Broadcast; + + + PROCEDURE Update* (v: View; rebuild: BOOLEAN); + VAR upd: UpdateMsg; + BEGIN + ASSERT(v # NIL, 20); + upd.scroll := FALSE; upd.rebuild := rebuild; upd.all := TRUE; + Broadcast(v, upd) + END Update; + + PROCEDURE UpdateIn* (v: View; l, t, r, b: INTEGER; rebuild: BOOLEAN); + VAR upd: UpdateMsg; + BEGIN + ASSERT(v # NIL, 20); + upd.scroll := FALSE; upd.rebuild := rebuild; upd.all := FALSE; + upd.l := l; upd.t := t; upd.r := r; upd.b := b; + Broadcast(v, upd) + END UpdateIn; + + PROCEDURE Scroll* (v: View; dx, dy: INTEGER); + VAR scroll: UpdateMsg; + BEGIN + ASSERT(v # NIL, 20); ASSERT(v.Domain() # NIL, 21); + RestoreDomain(v.Domain()); + scroll.scroll := TRUE; scroll.dx := dx; scroll.dy := dy; + Broadcast(v, scroll) + END Scroll; + + PROCEDURE CopyOf* (v: View; shallow: BOOLEAN): View; + VAR w, a: View; op: INTEGER; b: Alien; + BEGIN + ASSERT(v # NIL, 20); + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := NIL; actOp := handler; + IF shallow THEN copyModel := v.ThisModel() END; + actView := v; + w := Stores.CopyOf(v)(View); + actView := a; actOp := op + ELSE + NEW(b); w := b; w.bad := {handler..externalize} + END; + IF shallow THEN Stores.Join(w, v) END; + RETURN w + END CopyOf; + + PROCEDURE CopyWithNewModel* (v: View; m: Models.Model): View; + VAR w, a: View; op: INTEGER; b: Alien; fm: Models.Model; + BEGIN + ASSERT(v # NIL, 20); + fm := v.ThisModel(); ASSERT(fm # NIL, 21); + ASSERT(m # NIL, 22); + ASSERT(Services.SameType(m, fm), 23); + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := handler; + copyModel := m; + w := Stores.CopyOf(v)(View); + actView := a; actOp := op + ELSE + NEW(b); w := b; w.bad := {handler..externalize} + END; + RETURN w + END CopyWithNewModel; + + PROCEDURE ReadView* (VAR rd: Stores.Reader; OUT v: View); + VAR st: Stores.Store; a: Alien; + BEGIN + rd.ReadStore(st); + IF st = NIL THEN + v := NIL + ELSIF st IS Stores.Alien THEN + NEW(a); + a.store := st(Stores.Alien); Stores.Join(a, a.store); + v := a + ELSE + v := st(View) + END + END ReadView; + + PROCEDURE WriteView* (VAR wr: Stores.Writer; v: View); + VAR a: TrapAlien; av: View; op: INTEGER; + BEGIN + IF v = NIL THEN wr.WriteStore(v) + ELSIF externalize IN v.bad THEN NEW(a); wr.WriteStore(a) + ELSIF v IS Alien THEN wr.WriteStore(v(Alien).store) + ELSE + av := actView; op := actOp; actView := v; actOp := externalize; + wr.WriteStore(v); + actView := av; actOp := op + END + END WriteView; + + + (* frames *) + + PROCEDURE SetClip (f: Frame; l, t, r, b: INTEGER); + VAR u: INTEGER; + BEGIN + ASSERT(f.rider # NIL, 20); ASSERT(l <= r, 21); ASSERT(t <= b, 22); + u := f.unit; + f.rider.SetRect((l + f.gx) DIV u, (t + f.gy) DIV u, (r + f.gx) DIV u, (b + f.gy) DIV u); + f.l := l; f.t := t; f.r := r; f.b := b + END SetClip; + + PROCEDURE Close (f: Frame); + BEGIN + f.Close; + f.state := closed; + f.up := NIL; f.down := NIL; f.next := NIL; f.view := NIL; + f.ConnectTo(NIL) + END Close; + + PROCEDURE AdaptFrameTo (f: Frame; orgX, orgY: INTEGER); + VAR g, p, q: Frame; port: Ports.Port; + w, h, pl, pt, pr, pb, gl, gt, gr, gb, gx, gy: INTEGER; + BEGIN + (* pre: environment (i.e. parent frame / port) has already been set up *) + ASSERT(f.view # NIL, 20); ASSERT(f.view.context # NIL, 21); + f.x := orgX; f.y := orgY; (* set new origin *) + g := f.up; + IF g # NIL THEN (* parent frame is environment *) + f.gx0 := g.gx + orgX; f.gy0 := g.gy + orgY; + f.SetOffset(f.gx0 - f.sx, f.gy0 - f.sy); + pl := g.gx + g.l; pt := g.gy + g.t; pr := g.gx + g.r; pb := g.gy + g.b + ELSE (* port is environment *) + f.gx0 := orgX; f.gy0 := orgY; + f.SetOffset(f.gx0 - f.sx, f.gy0 - f.sy); + port := f.rider.Base(); + port.GetSize(w, h); + pl := 0; pt := 0; pr := w * f.unit; pb := h * f.unit + END; + (* (pl, pt, pr, pb) is parent clipping rectangle, in global coordinates, and in units *) + gx := f.gx; gy := f.gy; f.view.context.GetSize(w, h); + gl := gx; gt := gy; gr := gx + w; gb := gy + h; + (* (gl, gt, gr, gb) is desired clipping rectangle, in global coordinates, and in units *) + IF gl < pl THEN gl := pl END; + IF gt < pt THEN gt := pt END; + IF gr > pr THEN gr := pr END; + IF gb > pb THEN gb := pb END; + IF (gl >= gr) OR (gt >= gb) THEN gr := gl; gb := gt END; + SetClip(f, gl - gx + f.sx, gt - gy + f.sy, gr - gx + f.sx, gb - gy + f.sy); + (* (f.l, f.t, f.r, f.b) is final clipping rectangle, in local coordinates, and in units *) + g := f.down; f.down := NIL; p := NIL; + WHILE g # NIL DO (* adapt child frames *) + q := g.next; g.next := NIL; + AdaptFrameTo(g, g.x, g.y); + IF g.l = g.r THEN (* empty child frame: remove *) + Close(g) + ELSE (* insert in new frame list *) + IF p = NIL THEN f.down := g ELSE p.next := g END; + p := g + END; + g := q + END + (* post: frame is set; child frames are set, nonempty, and clipped to frame *) + END AdaptFrameTo; + + PROCEDURE SetRoot* (root: RootFrame; view: View; front: BOOLEAN; flags: SET); + BEGIN + ASSERT(root # NIL, 20); ASSERT(root.rider # NIL, 21); + ASSERT(view # NIL, 22); ASSERT(view.context # NIL, 23); + ASSERT(view.Domain() # NIL, 24); + ASSERT(root.state IN {new, open}, 25); + root.view := view; + root.front := front; root.mark := TRUE; root.flags := flags; + root.state := open; + IF root.update = NIL THEN NEW(root.update); root.update.n := 0 END + END SetRoot; + + PROCEDURE AdaptRoot* (root: RootFrame); + BEGIN + ASSERT(root # NIL, 20); ASSERT(root.state = open, 21); + AdaptFrameTo(root, root.x, root.y) + END AdaptRoot; + + PROCEDURE UpdateRoot* (root: RootFrame; l, t, r, b: INTEGER; rebuild: BOOLEAN); + BEGIN + ASSERT(root # NIL, 20); ASSERT(root.state = open, 21); + AddRect(root, root, l, t, r, b, rebuild) + END UpdateRoot; + + PROCEDURE RootOf* (f: Frame): RootFrame; + BEGIN + ASSERT(f # NIL, 20); ASSERT(f.state = open, 21); + WHILE f.up # NIL DO f := f.up END; + RETURN f(RootFrame) + END RootOf; + + PROCEDURE HostOf* (f: Frame): Frame; + BEGIN + ASSERT(f # NIL, 20); + RETURN f.up + END HostOf; + + PROCEDURE IsPrinterFrame* (f: Frame): BOOLEAN; + VAR p: Ports.Port; + BEGIN + ASSERT(f # NIL, 20); ASSERT(f.state = open, 21); + p := f.rider.Base(); + RETURN Ports.IsPrinterPort(p) + END IsPrinterFrame; + + PROCEDURE InstallFrame* (host: Frame; view: View; x, y, level: INTEGER; focus: BOOLEAN); + VAR e, f, g: Frame; w, h, l, t, r, b: INTEGER; m: Models.Model; std: StdFrame; + msg: UpdateCachesMsg; a: View; op: INTEGER; + BEGIN + ASSERT(host # NIL, 20); ASSERT(host.state = open, 21); + ASSERT(view # NIL, 22); ASSERT(view.context # NIL, 23); + ASSERT(view.Domain() # NIL, 24); + e := NIL; g := host.down; WHILE (g # NIL) & (g.view # view) DO e := g; g := g.next END; + IF g = NIL THEN (* frame for view not yet in child frame list *) + view.context.GetSize(w, h); + IF w > MAX(INTEGER) DIV 2 THEN w := MAX(INTEGER) DIV 2 END; + IF h > MAX(INTEGER) DIV 2 THEN h := MAX(INTEGER) DIV 2 END; + l := x; t := y; r := x + w; b := y + h; + (* (l, t, r, b) is child frame rectangle, in local coordinates, and in units *) + IF (l < host.r) & (t < host.b) & (r > host.l) & (b > host.t) THEN (* visible *) + g := NIL; view.GetNewFrame(g); + IF g = NIL THEN NEW(std); g := std END; + ASSERT(~(g IS RootFrame), 100); + e := NIL; f := host.down; WHILE (f # NIL) & (f.level <= level) DO e := f; f := f.next END; + IF e = NIL THEN g.next := host.down; host.down := g ELSE g.next := e.next; e.next := g END; + g.down := NIL; g.up := host; g.level := level; + g.view := view; + g.ConnectTo(host.rider.Base()); + g.state := open; + AdaptFrameTo(g, x, y); + IF ~(handler IN view.bad) THEN + a := actView; op := actOp; actView := view; actOp := handler; + view.HandleViewMsg(g, msg); + actView := a; actOp := op + END; + m := view.ThisModel(); + IF m # NIL THEN view.era := Models.Era(m) END; + END + ELSE + IF g.level # level THEN (* adapt to modified z-order *) + IF e = NIL THEN host.down := g.next ELSE e.next := g.next END; + e := NIL; f := host.down; WHILE (f # NIL) & (f.level <= level) DO e := f; f := f.next END; + IF e = NIL THEN g.next := host.down; host.down := g ELSE g.next := e.next; e.next := g END; + g.level := level + END; + AdaptFrameTo(g, x, y) (* may close g, leaving g.state = closed *) + (* possibly optimize: don't call Adapt if x=g.x, y=g.y, "host.era=g.era" *) + END; + IF (g # NIL) & (g.state = open) THEN + IF focus THEN + g.front := host.front; g.mark := host.mark + ELSE + g.front := FALSE; g.mark := FALSE + END + END + END InstallFrame; + + PROCEDURE RemoveAll (f: Frame); + VAR g, p: Frame; + BEGIN + g := f.down; WHILE g # NIL DO p := g.next; RemoveAll(g); Close(g); g := p END; + f.down := NIL + END RemoveAll; + + PROCEDURE RemoveFrame* (host, f: Frame); + VAR g, h: Frame; + BEGIN + ASSERT(host # NIL, 20); ASSERT(host.state = open, 21); + ASSERT(f # NIL, 22); ASSERT(f.up = host, 23); + g := host.down; h := NIL; + WHILE (g # NIL) & (g # f) DO h := g; g := g.next END; + ASSERT(g = f, 24); + IF h = NIL THEN host.down := f.next ELSE h.next := f.next END; + RemoveAll(f); Close(f) + END RemoveFrame; + + PROCEDURE RemoveFrames* (host: Frame; l, t, r, b: INTEGER); + VAR f, g: Frame; gl, gt, gr, gb: INTEGER; + BEGIN + ASSERT(host # NIL, 20); ASSERT(host.state = open, 21); + IF l < host.l THEN l := host.l END; + IF t < host.t THEN t := host.t END; + IF r > host.r THEN r := host.r END; + IF b > host.b THEN b := host.b END; + IF (l < r) & (t < b) THEN + gl := l + host.gx; gt := t + host.gy; gr := r + host.gx; gb := b + host.gy; + f := host.down; + WHILE f # NIL DO + g := f; f := f.next; + IF (gl < g.r + g.gx) & (g.l + g.gx < gr) & (gt < g.b + g.gy) & (g.t + g.gy < gb) THEN + RemoveFrame(host, g) + END + END + END + END RemoveFrames; + + PROCEDURE ThisFrame* (host: Frame; view: View): Frame; + VAR g: Frame; + BEGIN + ASSERT(host # NIL, 20); ASSERT(host.state = open, 21); + g := host.down; WHILE (g # NIL) & (g.view # view) DO g := g.next END; + RETURN g + END ThisFrame; + + PROCEDURE FrameAt* (host: Frame; x, y: INTEGER): Frame; + (** return frontmost sub-frame of host that contains (x, y) **) + VAR g, h: Frame; + BEGIN + ASSERT(host # NIL, 20); ASSERT(host.state = open, 21); + g := host.down; h := NIL; INC(x, host.gx); INC(y, host.gy); + WHILE g # NIL DO + IF (g.gx + g.l <= x) & (x < g.gx + g.r) & (g.gy + g.t <= y) & (y < g.gy + g.b) THEN + h := g + END; + g := g.next + END; + RETURN h + END FrameAt; + + PROCEDURE ShiftFrames (f: Frame; dx, dy: INTEGER); + VAR g, h: Frame; + BEGIN + g := f.down; + WHILE g # NIL DO + h := g; g := g.next; + AdaptFrameTo(h, h.x + dx, h.y + dy); + IF h.l = h.r THEN RemoveFrame(f, h) END + END + END ShiftFrames; + + PROCEDURE UpdateExposedArea (f: Frame; dx, dy: INTEGER); + VAR root: RootFrame; + BEGIN + root := RootOf(f); + IF dy > 0 THEN + AddRect(root, f, f.l, f.t, f.r, f.t + dy, keepFrames); + IF dx > 0 THEN + AddRect(root, f, f.l, f.t + dy, f.l + dx, f.b, keepFrames) + ELSE + AddRect(root, f, f.r + dx, f.t + dy, f.r, f.b, keepFrames) + END + ELSE + AddRect(root, f, f.l, f.b + dy, f.r, f.b, keepFrames); + IF dx > 0 THEN + AddRect(root, f, f.l, f.t, f.l + dx, f.b + dy, keepFrames) + ELSE + AddRect(root, f, f.r + dx, f.t, f.r, f.b + dy, keepFrames) + END + END + END UpdateExposedArea; + + PROCEDURE ScrollFrame (f: Frame; dx, dy: INTEGER); + VAR g: Frame; u, dx0, dy0: INTEGER; bitmapScrolling: BOOLEAN; msg: ScrollClassMsg; + BEGIN + g := f.up; + bitmapScrolling := TRUE; + IF (g # NIL) THEN + WHILE bitmapScrolling & (g.up # NIL) DO + msg.allowBitmapScrolling := FALSE; g.view.HandleViewMsg(g, msg); + bitmapScrolling := bitmapScrolling & msg.allowBitmapScrolling; + g := g.up + END + END; + IF bitmapScrolling THEN + u := f.unit; dx0 := dx; dy0 := dy; + INC(dx, f.sx); INC(dy, f.sy); DEC(f.l, f.sx); DEC(f.t, f.sy); DEC(f.r, f.sx); DEC(f.b, f.sy); + f.sx := dx MOD u; f.sy := dy MOD u; + DEC(dx, f.sx); DEC(dy, f.sy); INC(f.l, f.sx); INC(f.t, f.sy); INC(f.r, f.sx); INC(f.b, f.sy); + f.SetOffset(f.gx0 - f.sx, f.gy0 - f.sy); + ShiftFrames(f, dx0, dy0); + f.Scroll(dx, dy); + UpdateExposedArea(f, dx, dy) + ELSE AddRect(RootOf(f), f, f.l, f.t, f.r, f.b, rebuildFrames) + END + END ScrollFrame; + + PROCEDURE BroadcastModelMsg* (f: Frame; VAR msg: Models.Message); + VAR v, a: View; send: BOOLEAN; op: INTEGER; + BEGIN + ASSERT(f # NIL, 20); ASSERT(f.state = open, 21); + v := f.view; + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := handler; + IF msg.model # NIL THEN + IF (msg.model = v.ThisModel()) & (msg.era > v.era) THEN + send := (msg.era - v.era = 1); + v.era := msg.era; + IF ~send THEN + Log.synch := FALSE; + HALT(100) + END + ELSE send := FALSE + END + ELSE send := TRUE + END; + IF send THEN + WITH msg: Models.NeutralizeMsg DO + v.Neutralize + ELSE + v.HandleModelMsg(msg) + END + END; + actView := a; actOp := op + END; + f := f.down; WHILE f # NIL DO BroadcastModelMsg(f, msg); f := f.next END + END BroadcastModelMsg; + + PROCEDURE HandleUpdateMsg (f: Frame; VAR msg: UpdateMsg); + VAR root: RootFrame; g: Frame; l, t, r, b, dx, dy: INTEGER; + BEGIN + root := RootOf(f); + IF msg.scroll THEN + IF root.update.n = 0 THEN + ScrollFrame(f, msg.dx, msg.dy) + ELSE + AddRect(root, f, f.l, f.t, f.r, f.b, msg.rebuild) + END + ELSE + IF msg.all THEN + IF f # root THEN g := f.up ELSE g := root END; + dx := f.gx - g.gx; dy := f.gy - g.gy; + AddRect(root, g, f.l + dx, f.t + dy, f.r + dx, f.b + dy, msg.rebuild) + ELSE + l := msg.l; t := msg.t; r := msg.r; b := msg.b; + IF l < f.l THEN l := f.l END; + IF t < f.t THEN t := f.t END; + IF r > f.r THEN r := f.r END; + IF b > f.b THEN b := f.b END; + AddRect(root, f, l, t, r, b, msg.rebuild) + END + END + END HandleUpdateMsg; + + PROCEDURE BroadcastViewMsg* (f: Frame; VAR msg: Message); + VAR v, a: View; op: INTEGER; + BEGIN + ASSERT(f # NIL, 20); ASSERT(f.state = open, 21); + v := f.view; + IF (msg.view = v) OR (msg.view = NIL) THEN + WITH msg: UpdateMsg DO + HandleUpdateMsg(f, msg) + ELSE + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := handler; + v.HandleViewMsg(f, msg); + actView := a; actOp := op + END + END + END; + IF msg.view # v THEN + f := f.down; WHILE f # NIL DO BroadcastViewMsg(f, msg); f := f.next END + END + END BroadcastViewMsg; + + PROCEDURE ForwardCtrlMsg* (f: Frame; VAR msg: CtrlMessage); + CONST pre = 0; translate = 1; backoff = 2; final = 3; + VAR v, focus, a: View; g, h: Frame; op: INTEGER; req: BOOLEAN; + BEGIN + ASSERT(f # NIL, 20); ASSERT(f.state = open, 21); + v := f.view; + focus := NIL; g := f.up; req := FALSE; + HandleCtrlMsg(pre, f, g, msg, f.mark, f.front, req); + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := handler; + v.HandleCtrlMsg(f, msg, focus); + actView := a; actOp := op + END; + IF focus # NIL THEN (* propagate msg to another view *) + IF (f.focus # NIL) & (f.focus.view = focus) THEN (* cache hit *) + h := f.focus + ELSE (* cache miss *) + h := f.down; WHILE (h # NIL) & (h.view # focus) DO h := h.next END + END; + IF h # NIL THEN + HandleCtrlMsg(translate, f, h, msg, f.mark, f.front, req); + f.focus := h; ForwardCtrlMsg(h, msg); + HandleCtrlMsg(backoff, f, g, msg, f.mark, f.front, req) + END + ELSE + HandleCtrlMsg(final, f, g, msg, f.mark, f.front, req) + END; + IF req & (g # NIL) THEN g.view.ConsiderFocusRequestBy(f.view) END + END ForwardCtrlMsg; + + + PROCEDURE RestoreFrame (f: Frame; l, t, r, b: INTEGER); + VAR rd: Ports.Rider; g: Frame; v, a: View; op: INTEGER; + u, w, h, cl, ct, cr, cb, dx, dy: INTEGER; col: Ports.Color; + BEGIN + IF l < f.l THEN l := f.l END; + IF t < f.t THEN t := f.t END; + IF r > f.r THEN r := f.r END; + IF b > f.b THEN b := f.b END; + IF (l < r) & (t < b) THEN (* non-empty rectangle to be restored *) + v := f.view; rd := f.rider; u := f.unit; + rd.GetRect(cl, ct, cr, cb); (* save clip rectangle *) + rd.SetRect((f.gx + l) DIV u, (f.gy + t) DIV u, (f.gx + r) DIV u, (f.gy + b) DIV u); + IF ~(restore IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := restore; + col := transparent; v.GetBackground(col); + IF col # transparent THEN f.DrawRect(l, t, r, b, Ports.fill, col) END; + v.Restore(f, l, t, r, b); + g := f.down; + WHILE g # NIL DO (* loop over all subframes to handle overlaps *) + dx := f.gx - g.gx; dy := f.gy - g.gy; + RestoreFrame(g, l + dx, t + dy, r + dx, b + dy); + g := g.next + END; + v.RestoreMarks(f, l, t, r, b); + actView := a; actOp := op + END; + IF v.bad # {} THEN + IF externalize IN v.bad THEN + u := f.dot; v.context.GetSize(w, h); + f.DrawLine(0, 0, w - u, h - u, u, Ports.grey75); + f.DrawLine(w - u, 0, 0, h - u, u, Ports.grey75) + END; + f.MarkRect(l, t, r, b, Ports.fill, Ports.dim25, Ports.show) + END; + rd.SetRect(cl, ct, cr, cb) (* restore current clip rectangle *) + END + END RestoreFrame; + + PROCEDURE RestoreRoot* (root: RootFrame; l, t, r, b: INTEGER); + VAR port: Ports.Port; rd: Ports.Rider; + u, gl, gt, gr, gb: INTEGER; col: Ports.Color; + BEGIN + ASSERT(root # NIL, 20); ASSERT(root.state = open, 21); + ASSERT(root.update.n = 0, 22); + IF l < root.l THEN l := root.l END; + IF t < root.t THEN t := root.t END; + IF r > root.r THEN r := root.r END; + IF b > root.b THEN b := root.b END; + IF (l < r) & (t < b) THEN + u := root.unit; + gl := l + root.gx; gt := t + root.gy; gr := r + root.gx; gb := b + root.gy; + rd := root.rider; port := rd.Base(); + actFrame := root; + IF ~IsPrinterFrame(root) THEN port.OpenBuffer(gl DIV u, gt DIV u, gr DIV u, gb DIV u) END; + col := transparent; root.view.GetBackground(col); + ASSERT(col # transparent, 100); + RestoreFrame(root, l, t, r, b); + IF ~IsPrinterFrame(root) THEN port.CloseBuffer END; + actFrame := NIL + END + END RestoreRoot; + + PROCEDURE ThisCand (f: Frame; v: View): Frame; + (* find frame g with g.view = v *) + VAR g: Frame; + BEGIN + WHILE (f # NIL) & (f.view # v) DO + g := ThisCand(f.down, v); + IF g # NIL THEN f := g ELSE f := f.next END + END; + RETURN f + END ThisCand; + + PROCEDURE ValidateRoot* (root: RootFrame); + VAR rgn: Region; f: Frame; v: View; i, n: INTEGER; + BEGIN + ASSERT(root # NIL, 20); ASSERT(root.state = open, 21); + rgn := root.update; n := rgn.n; rgn.n := 0; i := 0; + WHILE i < n DO + IF rgn.r[i].rebuild THEN + v := rgn.r[i].v; + IF v # NIL THEN f := ThisCand(root, v) ELSE f := NIL END; + IF f = NIL THEN f := root END; + RemoveFrames(f, rgn.r[i].l - f.gx, rgn.r[i].t - f.gy, rgn.r[i].r - f.gx, rgn.r[i].b - f.gy) + END; + INC(i) + END; + i := 0; + WHILE i < n DO + RestoreRoot(root, rgn.r[i].l - root.gx, rgn.r[i].t - root.gy, rgn.r[i].r - root.gx, rgn.r[i].b - root.gy); + INC(i) + END + END ValidateRoot; + + PROCEDURE MarkBordersIn (f: Frame); + VAR g: Frame; w, h: INTEGER; + BEGIN + g := f.down; + WHILE g # NIL DO + g.view.context.GetSize(w, h); + MarkBorder(f, g.view, g.x, g.y, g.x + w, g.y + h); + MarkBordersIn(g); + g := g.next + END + END MarkBordersIn; + + PROCEDURE MarkBorders* (root: RootFrame); + BEGIN + MarkBordersIn(root) + END MarkBorders; + + PROCEDURE ReadFont* (VAR rd: Stores.Reader; OUT f: Fonts.Font); + VAR version: INTEGER; + fingerprint, size: INTEGER; typeface: Fonts.Typeface; style: SET; weight: INTEGER; + BEGIN + rd.ReadVersion(0, 0, version); + rd.ReadInt(fingerprint); + rd.ReadXString(typeface); rd.ReadInt(size); rd.ReadSet(style); rd.ReadXInt(weight); + f := Fonts.dir.This(typeface, size, style, weight); ASSERT(f # NIL, 60); + IF f.IsAlien() THEN + Stores.Report("#System:AlienFont", typeface, "", "") + END + END ReadFont; + + PROCEDURE WriteFont* (VAR wr: Stores.Writer; f: Fonts.Font); + BEGIN + ASSERT(f # NIL, 20); + wr.WriteVersion(0); + wr.WriteInt(0); + wr.WriteXString(f.typeface); wr.WriteInt(f.size); wr.WriteSet(f.style); wr.WriteXInt(f.weight) + END WriteFont; + + + (** view/file interaction **) + + PROCEDURE Old* (ask: BOOLEAN; + VAR loc: Files.Locator; VAR name: Files.Name; VAR conv: Converters.Converter): View; + VAR v: View; + BEGIN + ASSERT(ask OR (loc # NIL), 20); + ASSERT(ask OR (name # ""), 21); + IF ask THEN + ASSERT(getSpecHook # NIL, 101); + getSpecHook.GetIntSpec(loc, name, conv) + END; + IF (loc # NIL) & (name # "") THEN + ASSERT(viewHook # NIL, 100); + v := viewHook.OldView(loc, name, conv) + ELSE v := NIL + END; + RETURN v + END Old; + + PROCEDURE OldView* (loc: Files.Locator; name: Files.Name): View; + VAR conv: Converters.Converter; + BEGIN + conv := NIL; + RETURN Old(dontAsk, loc, name, conv) + END OldView; + + PROCEDURE Register* (view: View; ask: BOOLEAN; + VAR loc: Files.Locator; VAR name: Files.Name; VAR conv: Converters.Converter; OUT res: INTEGER); + BEGIN + ASSERT(viewHook # NIL, 100); + ASSERT(getSpecHook # NIL, 101); + ASSERT(view # NIL, 20); + ASSERT(ask OR (loc # NIL), 22); ASSERT(ask OR (name # ""), 23); + IF ask OR (loc = NIL) OR (name = "") OR (loc.res = 77) THEN + getSpecHook.GetExtSpec(view, loc, name, conv) + END; + IF (loc # NIL) & (name # "") THEN + viewHook.RegisterView(view, loc, name, conv); res := loc.res + ELSE res := 7 + END + END Register; + + PROCEDURE RegisterView* (view: View; loc: Files.Locator; name: Files.Name); + VAR res: INTEGER; conv: Converters.Converter; + BEGIN + conv := NIL; + Register(view, dontAsk, loc, name, conv, res) + END RegisterView; + + (** direct view opening **) + + PROCEDURE Open* (view: View; loc: Files.Locator; name: Files.Name; conv: Converters.Converter); + BEGIN + ASSERT(view # NIL, 20); ASSERT((loc = NIL) = (name = ""), 21); + ASSERT(viewHook # NIL, 100); + viewHook.Open(view, name, loc, name, conv, FALSE, FALSE, FALSE, FALSE, FALSE) + END Open; + + PROCEDURE OpenView* (view: View); + BEGIN + ASSERT(view # NIL, 20); + Open(view, NIL, "", NIL) + END OpenView; + + PROCEDURE OpenAux* (view: View; title: Title); + BEGIN + ASSERT(view # NIL, 20); ASSERT(viewHook # NIL, 100); + IF title = "" THEN title := "#System:untitled" END; + viewHook.Open(view, title, NIL, "", NIL, FALSE, TRUE, FALSE, TRUE, TRUE) + END OpenAux; + + + (** view producer/consumer decoupling **) + + PROCEDURE Deposit* (view: View); + VAR q: QueueElem; + BEGIN + ASSERT(view # NIL, 20); + NEW(q); q.view := view; + IF queue.head = NIL THEN queue.head := q ELSE queue.tail.next := q END; + queue.tail := q; INC(queue.len) + END Deposit; + + PROCEDURE Fetch* (OUT view: View); + VAR q: QueueElem; + BEGIN + q := queue.head; ASSERT(q # NIL, 20); + DEC(queue.len); queue.head := q.next; + IF queue.head = NIL THEN queue.tail := NIL END; + view := q.view + END Fetch; + + PROCEDURE Available* (): INTEGER; + BEGIN + RETURN queue.len + END Available; + + PROCEDURE ClearQueue*; + BEGIN + queue.len := 0; queue.head := NIL; queue.tail := NIL; + actView := NIL (* HACK! prevents invalidation of view due to trap in Dialog.Call *) + END ClearQueue; + + + (** attach controller framework **) + + PROCEDURE InitCtrl* (p: CtrlMsgHandler); + BEGIN + ASSERT(HandleCtrlMsg = NIL, 20); HandleCtrlMsg := p + END InitCtrl; + + PROCEDURE (h: NotifyHook) Notify (id0, id1: INTEGER; opts: SET); + VAR msg: NotifyMsg; + BEGIN + ASSERT(msgHook # NIL, 100); + msg.id0 := id0; msg.id1 := id1; msg.opts := opts; + msgHook.Omnicast(msg) + END Notify; + + PROCEDURE Omnicast* (VAR msg: ANYREC); + BEGIN + msgHook.Omnicast(msg) + END Omnicast; + + PROCEDURE HandlePropMsg* (v: View; VAR msg: PropMessage); + VAR a: View; op: INTEGER; + BEGIN + IF ~(handler IN v.bad) THEN + a := actView; op := actOp; actView := v; actOp := handler; + v.HandlePropMsg(msg); + actView := a; actOp := op + END + END HandlePropMsg; + + + (* view invalidation *) + + PROCEDURE IsInvalid* (v: View): BOOLEAN; + BEGIN + RETURN v.bad # {} + END IsInvalid; + + PROCEDURE RevalidateView* (v: View); + BEGIN + v.bad := {}; + Update(v, keepFrames) + END RevalidateView; + + PROCEDURE TrapCleanup; + BEGIN + copyModel := NIL; + IF actView # NIL THEN + INCL(actView.bad, actOp); + IF actFrame # NIL THEN + UpdateRoot(actFrame, actFrame.l, actFrame.t, actFrame.r, actFrame.b, keepFrames); + actFrame := NIL + END; + Update(actView, keepFrames); + actView := NIL + END + END TrapCleanup; + + PROCEDURE Init; + VAR h: NotifyHook; + BEGIN + NEW(h); Dialog.SetNotifyHook(h); + domainGuard := 0; ClearQueue; + Kernel.InstallTrapChecker(TrapCleanup) + END Init; + +BEGIN + Init +END Views. diff --git a/Trurl-based/System/Mod/Windows.txt b/Trurl-based/System/Mod/Windows.txt new file mode 100644 index 0000000..abe145d --- /dev/null +++ b/Trurl-based/System/Mod/Windows.txt @@ -0,0 +1,855 @@ +MODULE Windows; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Windows.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Ports, Files, Services, + Stores, Sequencers, Models, Views, Controllers, Properties, + Dialog, Converters, Containers, Documents; + + CONST + (** Window.flags **) + isTool* = 0; isAux* = 1; + noHScroll* = 2; noVScroll* = 3; noResize* = 4; + allowDuplicates* = 5; neverDirty* = 6; + + (** Directory.Select lazy **) + eager* = FALSE; lazy* = TRUE; + + notRecorded = 3; + + TYPE + Window* = POINTER TO ABSTRACT RECORD + port-: Ports.Port; + frame-: Views.RootFrame; + doc-: Documents.Document; + seq-: Sequencers.Sequencer; + link-: Window; (* ring of windows with same sequencer *) + sub-: BOOLEAN; + flags-: SET; + loc-: Files.Locator; + name-: Files.Name; + conv-: Converters.Converter + END; + + Directory* = POINTER TO ABSTRACT RECORD + l*, t*, r*, b*: INTEGER; + minimized*, maximized*: BOOLEAN + END; + + + OpElem = POINTER TO RECORD + next: OpElem; + st: Stores.Store; + op: Stores.Operation; + name: Stores.OpName; + invisible, transparent: BOOLEAN + END; + + Script = POINTER TO RECORD (Stores.Operation) + up: Script; + list: OpElem; + level: INTEGER; (* nestLevel at creation time *) + name: Stores.OpName + END; + + StdSequencer = POINTER TO RECORD (Sequencers.Sequencer) + home: Window; + trapEra: INTEGER; (* last observed TrapCount value *) + modLevel: INTEGER; (* dirty if modLevel > 0 *) + entryLevel: INTEGER; (* active = (entryLevel > 0) *) + nestLevel: INTEGER; (* nesting level of BeginScript/Modification *) + modStack: ARRAY 64 OF RECORD store: Stores.Store; type: INTEGER END; + lastSt: Stores.Store; + lastOp: Stores.Operation; + script: Script; + undo, redo: OpElem; (* undo/redo stacks *) + noUndo: BOOLEAN; (* script # NIL and BeginModification called *) + invisibleLevel, transparentLevel, notRecordedLevel: INTEGER + END; + + SequencerDirectory = POINTER TO RECORD (Sequencers.Directory) END; + + Forwarder = POINTER TO RECORD (Controllers.Forwarder) END; + + RootContext = POINTER TO RECORD (Models.Context) + win: Window + END; + + Reducer = POINTER TO RECORD (Kernel.Reducer) END; + + Hook = POINTER TO RECORD (Views.MsgHook) END; + + CheckAction = POINTER TO RECORD (Services.Action) + wait: WaitAction + END; + + WaitAction = POINTER TO RECORD (Services.Action) + check: CheckAction + END; + + LangNotifier = POINTER TO RECORD (Dialog.LangNotifier) END; + + VAR dir-, stdDir-: Directory; + + PROCEDURE ^ Reset (s: StdSequencer); + + + PROCEDURE CharError; + BEGIN + Dialog.Beep + END CharError; + + + + (** Window **) + + PROCEDURE (w: Window) Init* (port: Ports.Port), NEW; + BEGIN + ASSERT(w.port = NIL, 20); ASSERT(port # NIL, 21); + w.port := port + END Init; + + PROCEDURE (w: Window) SetTitle* (title: Views.Title), NEW, ABSTRACT; + PROCEDURE (w: Window) GetTitle* (OUT title: Views.Title), NEW, ABSTRACT; + PROCEDURE (w: Window) RefreshTitle* (), NEW, ABSTRACT; + + PROCEDURE (w: Window) SetSpec* (loc: Files.Locator; name: Files.Name; conv: Converters.Converter), NEW, EXTENSIBLE; + VAR u: Window; + BEGIN + u := w; + REPEAT + u := u.link; + u.loc := loc; u.name := name$; u.conv := conv + UNTIL u = w + END SetSpec; + + PROCEDURE (w: Window) Restore* (l, t, r, b: INTEGER), NEW; + VAR f: Views.Frame; u, pw, ph: INTEGER; + BEGIN + f := w.frame; + IF f # NIL THEN + w.port.GetSize(pw, ph); u := w.port.unit; + IF r > pw THEN r := pw END; + IF b > ph THEN b := ph END; + l := l * u - f.gx; t := t * u - f.gy; r := r * u - f.gx; b := b * u - f.gy; + (* only adds to the BlackBox region, but doesn't draw: *) + Views.UpdateRoot(w.frame, l, t, r, b, Views.keepFrames) + END + END Restore; + + PROCEDURE (w: Window) Update*, NEW; + BEGIN + ASSERT(w.frame # NIL, 20); + (* redraws the whole accumulated BlackBox region: *) + Views.ValidateRoot(w.frame) + END Update; + + PROCEDURE (w: Window) GetSize*(OUT width, height: INTEGER), NEW, EXTENSIBLE; + BEGIN + w.port.GetSize(width, height) + END GetSize; + + PROCEDURE (w: Window) SetSize* (width, height: INTEGER), NEW, EXTENSIBLE; + VAR c: Containers.Controller; w0, h0: INTEGER; + BEGIN + w.port.GetSize(w0, h0); + w.port.SetSize(width, height); + IF w.frame # NIL THEN Views.AdaptRoot(w.frame) END; + c := w.doc.ThisController(); + IF c.opts * {Documents.winWidth, Documents.winHeight} # {} THEN + w.Restore(0, 0, width, height) + END + END SetSize; + + PROCEDURE (w: Window) BroadcastModelMsg* (VAR msg: Models.Message), NEW, EXTENSIBLE; + BEGIN + IF w.frame # NIL THEN + Views.BroadcastModelMsg(w.frame, msg) + END + END BroadcastModelMsg; + + PROCEDURE (w: Window) BroadcastViewMsg* (VAR msg: Views.Message), NEW, EXTENSIBLE; + BEGIN + IF w.frame # NIL THEN + Views.BroadcastViewMsg(w.frame, msg) + END + END BroadcastViewMsg; + + PROCEDURE (w: Window) ForwardCtrlMsg* (VAR msg: Controllers.Message), NEW, EXTENSIBLE; + BEGIN + IF w.frame # NIL THEN + WITH msg: Controllers.CursorMessage DO + DEC(msg.x, w.frame.gx); DEC(msg.y, w.frame.gy) + ELSE + END; + Views.ForwardCtrlMsg(w.frame, msg) + END + END ForwardCtrlMsg; + + PROCEDURE (w: Window) MouseDown* (x, y, time: INTEGER; modifiers: SET), NEW, ABSTRACT; + + PROCEDURE (w: Window) KeyDown* (ch: CHAR; modifiers: SET), NEW, EXTENSIBLE; + VAR key: Controllers.EditMsg; + BEGIN + IF ch = 0X THEN + CharError + ELSE + key.op := Controllers.pasteChar; key.char := ch; + key.modifiers:= modifiers; + w.ForwardCtrlMsg(key) + END + END KeyDown; + + PROCEDURE (w: Window) Close*, NEW, EXTENSIBLE; + VAR u: Window; f: Views.Frame; s: Sequencers.Sequencer; msg: Sequencers.RemoveMsg; + BEGIN + u := w.link; WHILE u.link # w DO u := u.link END; + u.link := w.link; + f := w.frame; s := w.seq; + IF ~w.sub THEN s.Notify(msg) END; + WITH s: StdSequencer DO + IF s.home = w THEN s.home := NIL END + ELSE + END; + w.port.SetSize(0, 0); Views.AdaptRoot(w.frame); + w.port := NIL; w.frame := NIL; w.doc := NIL; w.seq := NIL; w.link := NIL; w.loc := NIL; + f.Close + END Close; + + + (** Directory **) + + PROCEDURE (d: Directory) NewSequencer* (): Sequencers.Sequencer, NEW; + VAR s: StdSequencer; + BEGIN + NEW(s); Reset(s); RETURN s + END NewSequencer; + + + PROCEDURE (d: Directory) First* (): Window, NEW, ABSTRACT; + PROCEDURE (d: Directory) Next* (w: Window): Window, NEW, ABSTRACT; + + PROCEDURE (d: Directory) New* (): Window, NEW, ABSTRACT; + + PROCEDURE (d: Directory) Open* (w: Window; doc: Documents.Document; + flags: SET; name: Views.Title; + loc: Files.Locator; fname: Files.Name; + conv: Converters.Converter), + NEW, EXTENSIBLE; + VAR v: Views.View; c: RootContext; s: Sequencers.Sequencer; f: Views.Frame; any: ANYPTR; + BEGIN + ASSERT(w # NIL, 20); ASSERT(doc # NIL, 21); ASSERT(doc.context = NIL, 22); + v := doc.ThisView(); ASSERT(v # NIL, 23); + ASSERT(w.doc = NIL, 24); ASSERT(w.port # NIL, 25); + IF w.link = NIL THEN w.link := w END; (* create new window ring *) + w.doc := doc; w.flags := flags; + IF w.seq = NIL THEN + ASSERT(doc.Domain() # NIL, 27); + any := doc.Domain().GetSequencer(); + IF any # NIL THEN + ASSERT(any IS Sequencers.Sequencer, 26); + w.seq := any(Sequencers.Sequencer) + ELSE + w.seq := d.NewSequencer(); + doc.Domain().SetSequencer(w.seq) + END + END; + s := w.seq; + WITH s: StdSequencer DO + IF s.home = NIL THEN s.home := w END + ELSE + END; + NEW(c); c.win := w; doc.InitContext(c); + doc.GetNewFrame(f); w.frame := f(Views.RootFrame); + w.frame.ConnectTo(w.port); + Views.SetRoot(w.frame, w.doc, FALSE, w.flags); + w.SetSpec(loc, fname, conv) + END Open; + + PROCEDURE (d: Directory) OpenSubWindow* (w: Window; doc: Documents.Document; flags: SET; name: Views.Title), NEW, EXTENSIBLE; + VAR u: Window; title: Views.Title; + BEGIN + ASSERT(w # NIL, 20); ASSERT(doc # NIL, 21); + u := d.First(); WHILE (u # NIL) & (u.seq # doc.Domain().GetSequencer()) DO u := d.Next(u) END; + IF u # NIL THEN + w.sub := TRUE; + w.link := u.link; u.link := w; + w.seq := u.seq; w.loc := u.loc; w.name := u.name; w.conv := u.conv; + u.GetTitle(title); + d.Open(w, doc, flags, title, u.loc, u.name, u.conv) + ELSE + d.Open(w, doc, flags, name, NIL, "", NIL) + END + END OpenSubWindow; + + PROCEDURE ^ RestoreSequencer(seq: Sequencers.Sequencer); + + PROCEDURE (d: Directory) Focus* (target: BOOLEAN): Window, NEW, ABSTRACT; + PROCEDURE (d: Directory) GetThisWindow* (p: Ports.Port; px, py: INTEGER; OUT x, y: INTEGER; OUT w: Window), NEW, ABSTRACT; + PROCEDURE (d: Directory) Select* (w: Window; lazy: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (d: Directory) Close* (w: Window), NEW, ABSTRACT; + + PROCEDURE (d: Directory) Update* (w: Window), NEW; + VAR u: Window; + BEGIN + (* redraws the BlackBox region of a given window, or of all windows *) + u := d.First(); + WHILE u # NIL DO + ASSERT(u.frame # NIL, 101); + IF (u = w) OR (w = NIL) THEN RestoreSequencer(u.seq) END; + u := d.Next(u) + END + END Update; + + PROCEDURE (d: Directory) GetBounds* (OUT w, h: INTEGER), NEW, ABSTRACT; + + + (* RootContext *) + + PROCEDURE (c: RootContext) GetSize (OUT w, h: INTEGER); + BEGIN + c.win.port.GetSize(w, h); + w := w * c.win.port.unit; h := h * c.win.port.unit + END GetSize; + + PROCEDURE (c: RootContext) SetSize (w, h: INTEGER); + END SetSize; + + PROCEDURE (c: RootContext) Normalize (): BOOLEAN; + BEGIN + RETURN TRUE + END Normalize; + + PROCEDURE (c: RootContext) ThisModel (): Models.Model; + BEGIN + RETURN NIL + END ThisModel; + + + (* sequencing utilities *) + + PROCEDURE Prepend (s: Script; st: Stores.Store; IN name: Stores.OpName; op: Stores.Operation); + VAR e: OpElem; + BEGIN + ASSERT(op # NIL, 20); + NEW(e); e.st := st; e.op := op; e.name := name; + e.next := s.list; s.list := e + END Prepend; + + PROCEDURE Push (VAR list, e: OpElem); + BEGIN + e.next := list; list := e + END Push; + + PROCEDURE Pop (VAR list, e: OpElem); + BEGIN + e := list; list := list.next + END Pop; + + PROCEDURE Reduce (VAR list: OpElem; max: INTEGER); + VAR e: OpElem; + BEGIN + e := list; WHILE (max > 1) & (e # NIL) DO DEC(max); e := e.next END; + IF e # NIL THEN e.next := NIL END + END Reduce; + + PROCEDURE (r: Reducer) Reduce (full: BOOLEAN); + VAR e: OpElem; n: INTEGER; w: Window; + BEGIN + IF dir # NIL THEN + w := dir.First(); + WHILE w # NIL DO + IF w.seq IS StdSequencer THEN + IF full THEN + n := 1 + ELSE + n := 0; e := w.seq(StdSequencer).undo; + WHILE e # NIL DO INC(n); e := e.next END; + IF n > 20 THEN n := n DIV 2 ELSE n := 10 END + END; + Reduce(w.seq(StdSequencer).undo, n) + END; + w := dir.Next(w) + END + END; + Kernel.InstallReducer(r) + END Reduce; + + PROCEDURE Reset (s: StdSequencer); + BEGIN + s.trapEra := Kernel.trapCount; + IF (s.entryLevel # 0) OR (s.nestLevel # 0) THEN + s.modLevel := 0; + s.entryLevel := 0; + s.nestLevel := 0; + s.lastSt := NIL; + s.lastOp := NIL; + s.script := NIL; + s.noUndo := FALSE; + s.undo := NIL; s.redo := NIL; + s.invisibleLevel := 0; + s.transparentLevel := 0; + s.notRecordedLevel := 0 + END + END Reset; + + PROCEDURE Neutralize (st: Stores.Store); + VAR neutralize: Models.NeutralizeMsg; + BEGIN + IF st # NIL THEN (* st = NIL for scripts *) + WITH st: Models.Model DO + Models.Broadcast(st, neutralize) + | st: Views.View DO + st.Neutralize + ELSE + END + END + END Neutralize; + + PROCEDURE Do (s: StdSequencer; st: Stores.Store; op: Stores.Operation); + BEGIN + INC(s.entryLevel); s.lastSt := NIL; s.lastOp := NIL; + Neutralize(st); op.Do; + DEC(s.entryLevel) + END Do; + + PROCEDURE AffectsDoc (s: StdSequencer; st: Stores.Store): BOOLEAN; + VAR v, w: Window; + BEGIN + w := s.home; + IF (w = NIL) OR (st = w.doc) OR (st = w.doc.ThisView()) THEN + RETURN TRUE + ELSE + v := w.link; + WHILE (v # w) & (st # v.doc) & (st # v.doc.ThisView()) DO v := v.link END; + RETURN v = w + END + END AffectsDoc; + + + (* Script *) + + PROCEDURE (s: Script) Do; + VAR e, f, g: OpElem; + BEGIN + e := s.list; f := NIL; + REPEAT + Neutralize(e.st); e.op.Do; + g := e.next; e.next := f; f := e; e := g + UNTIL e = NIL; + s.list := f + END Do; + + + (* StdSequencer *) + + PROCEDURE (s: StdSequencer) Handle (VAR msg: ANYREC); + (* send message to all windows attached to s *) + VAR w: Window; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + WITH msg: Models.Message DO + IF msg IS Models.UpdateMsg THEN + Properties.IncEra; + IF s.entryLevel = 0 THEN + (* updates in dominated model bypassed the sequencer *) + Reset(s); (* panic reset: clear sequencer *) + INC(s.modLevel) (* but leave dirty *) + END + END; + w := dir.First(); + WHILE w # NIL DO + IF w.seq = s THEN w.BroadcastModelMsg(msg) END; + w := dir.Next(w) + END + | msg: Views.Message DO + w := dir.First(); + WHILE w # NIL DO + IF w.seq = s THEN w.BroadcastViewMsg(msg) END; + w := dir.Next(w) + END + ELSE + END + END Handle; + + + PROCEDURE (s: StdSequencer) Dirty (): BOOLEAN; + BEGIN + RETURN s.modLevel > 0 + END Dirty; + + PROCEDURE (s: StdSequencer) SetDirty (dirty: BOOLEAN); + BEGIN + IF dirty THEN INC(s.modLevel) ELSE s.modLevel := 0 END + END SetDirty; + + PROCEDURE (s: StdSequencer) LastOp (st: Stores.Store): Stores.Operation; + BEGIN + ASSERT(st # NIL, 20); + IF s.lastSt = st THEN RETURN s.lastOp ELSE RETURN NIL END + END LastOp; + + + PROCEDURE (s: StdSequencer) BeginScript (IN name: Stores.OpName; VAR script: Stores.Operation); + VAR sop: Script; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + INC(s.nestLevel); + IF (s.nestLevel = 1) & (s.invisibleLevel = 0) & (s.transparentLevel = 0) & (s.notRecordedLevel = 0) THEN + INC(s.modLevel) + END; + s.lastSt := NIL; s.lastOp := NIL; + NEW(sop); sop.up := s.script; sop.list := NIL; sop.level := s.nestLevel; sop.name := name; + s.script := sop; + script := sop + END BeginScript; + + PROCEDURE (s: StdSequencer) Do (st: Stores.Store; IN name: Stores.OpName; op: Stores.Operation); + VAR e: OpElem; + BEGIN + ASSERT(st # NIL, 20); ASSERT(op # NIL, 21); + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + Do(s, st, op); + IF s.noUndo THEN (* cannot undo: unbalanced BeginModification pending *) + s.lastSt := NIL; s.lastOp := NIL + ELSIF (s.entryLevel = 0) (* don't record when called from within op.Do *) + & AffectsDoc(s, st) THEN (* don't record when Do affected child window only *) + s.lastSt := st; s.lastOp := op; + s.redo := NIL; (* clear redo stack *) + IF s.script # NIL THEN + Prepend(s.script, st, name, op) + ELSE + IF (s.invisibleLevel = 0) & (s.transparentLevel = 0) & (s.notRecordedLevel = 0) THEN INC(s.modLevel) END; + NEW(e); e.st := st; e.op := op; e.name := name; + e.invisible := s.invisibleLevel > 0; e.transparent := s.transparentLevel > 0; + IF (s.notRecordedLevel=0) THEN Push(s.undo, e) END + END + END + END Do; + + PROCEDURE (s: StdSequencer) Bunch (st: Stores.Store); + VAR lastOp: Stores.Operation; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + ASSERT(st # NIL, 20); ASSERT(st = s.lastSt, 21); + lastOp := s.lastOp; + Do(s, st, lastOp); + IF s.noUndo THEN + s.lastSt := NIL; s.lastOp := NIL + ELSIF (s.entryLevel = 0) (* don't record when called from within op.Do *) + & AffectsDoc(s, st) THEN (* don't record when Do affected child window only *) + s.lastSt := st; s.lastOp := lastOp + END + END Bunch; + + PROCEDURE (s: StdSequencer) EndScript (script: Stores.Operation); + VAR e: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + ASSERT(script # NIL, 20); ASSERT(s.script = script, 21); + WITH script: Script DO + ASSERT(s.nestLevel = script.level, 22); + s.script := script.up; + IF s.entryLevel = 0 THEN (* don't record when called from within op.Do *) + IF script.list # NIL THEN + IF s.script # NIL THEN + Prepend(s.script, NIL, script.name, script) + ELSE (* outermost scripting level *) + s.redo := NIL; (* clear redo stack *) + IF ~s.noUndo THEN + NEW(e); e.st := NIL; e.op := script; e.name := script.name; + e.invisible := s.invisibleLevel > 0; e.transparent := s.transparentLevel > 0; + IF s.notRecordedLevel=0 THEN Push(s.undo, e) END + END; + s.lastSt := NIL; s.lastOp := NIL + END + ELSE + IF (s.script = NIL) & (s.modLevel > 0) & (s.invisibleLevel = 0) & (s.transparentLevel = 0) THEN + DEC(s.modLevel) + END + END + END + END; + DEC(s.nestLevel); + IF s.nestLevel = 0 THEN ASSERT(s.script = NIL, 22); s.noUndo := FALSE END + END EndScript; + + PROCEDURE (s: StdSequencer) StopBunching; + BEGIN + s.lastSt := NIL; s.lastOp := NIL + END StopBunching; + + PROCEDURE (s: StdSequencer) BeginModification (type: INTEGER; st: Stores.Store); + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + IF s.nestLevel < LEN(s.modStack) THEN s.modStack[s.nestLevel].store := st; s.modStack[s.nestLevel].type := type END; + INC(s.nestLevel); + IF type = Sequencers.notUndoable THEN + INC(s.modLevel); (* unbalanced! *) + s.noUndo := TRUE; s.undo := NIL; s.redo := NIL; + s.lastSt := NIL; s.lastOp := NIL; + INC(s.entryLevel) (* virtual entry of modification "operation" *) + ELSIF type = Sequencers.invisible THEN + INC(s.invisibleLevel) + ELSIF type = Sequencers.clean THEN + INC(s.transparentLevel) + ELSIF type = notRecorded THEN + INC(s.notRecordedLevel) + END + END BeginModification; + + PROCEDURE (s: StdSequencer) EndModification (type: INTEGER; st: Stores.Store); + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + ASSERT(s.nestLevel > 0, 20); + IF s.nestLevel <= LEN(s.modStack) THEN + ASSERT((s.modStack[s.nestLevel - 1].store = st) & (s.modStack[s.nestLevel - 1].type = type), 21) + END; + DEC(s.nestLevel); + IF type = Sequencers.notUndoable THEN + DEC(s.entryLevel) + ELSIF type = Sequencers.invisible THEN + DEC(s.invisibleLevel) + ELSIF type = Sequencers.clean THEN + DEC(s.transparentLevel) + ELSIF type = notRecorded THEN + DEC(s.notRecordedLevel) + END; + IF s.nestLevel = 0 THEN ASSERT(s.script = NIL, 22); s.noUndo := FALSE END + END EndModification; + + PROCEDURE (s: StdSequencer) CanUndo (): BOOLEAN; + VAR op: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + op := s.undo; + WHILE (op # NIL) & op.invisible DO op := op.next END; + RETURN op # NIL + END CanUndo; + + PROCEDURE (s: StdSequencer) CanRedo (): BOOLEAN; + VAR op: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + op := s.redo; + WHILE (op # NIL) & op.invisible DO op := op.next END; + RETURN op # NIL + END CanRedo; + + PROCEDURE (s: StdSequencer) GetUndoName (VAR name: Stores.OpName); + VAR op: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + op := s.undo; + WHILE (op # NIL) & op.invisible DO op := op.next END; + IF op # NIL THEN name := op.name$ ELSE name[0] := 0X END + END GetUndoName; + + PROCEDURE (s: StdSequencer) GetRedoName (VAR name: Stores.OpName); + VAR op: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + op := s.redo; + WHILE (op # NIL) & op.invisible DO op := op.next END; + IF op # NIL THEN name := op.name$ ELSE name[0] := 0X END + END GetRedoName; + + PROCEDURE (s: StdSequencer) Undo; + VAR e: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + IF s.undo # NIL THEN + REPEAT + Pop(s.undo, e); Do(s, e.st, e.op); Push(s.redo, e) + UNTIL ~e.invisible OR (s.undo = NIL); + IF ~e.transparent THEN + IF s.modLevel > 0 THEN DEC(s.modLevel) END + END + END + END Undo; + + PROCEDURE (s: StdSequencer) Redo; + VAR e: OpElem; + BEGIN + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + IF s.redo # NIL THEN + Pop(s.redo, e); Do(s, e.st, e.op); Push(s.undo, e); + WHILE (s.redo # NIL) & s.redo.invisible DO + Pop(s.redo, e); Do(s, e.st, e.op); Push(s.undo, e) + END; + IF ~e.transparent THEN + INC(s.modLevel) + END + END + END Redo; + + + (* Forwarder *) + + PROCEDURE (f: Forwarder) Forward (target: BOOLEAN; VAR msg: Controllers.Message); + VAR w: Window; + BEGIN + w := dir.Focus(target); + IF w # NIL THEN w.ForwardCtrlMsg(msg) END + END Forward; + + PROCEDURE (f: Forwarder) Transfer (VAR msg: Controllers.TransferMessage); + VAR w: Window; h: Views.Frame; p: Ports.Port; sx, sy, tx, ty, pw, ph: INTEGER; + BEGIN + h := msg.source; p := h.rider.Base(); + (* (msg.x, msg.y) is point in local coordinates of source frame *) + sx := (msg.x + h.gx) DIV h.unit; + sy := (msg.y + h.gy) DIV h.unit; + (* (sx, sy) is point in global coordinates of source port *) + dir.GetThisWindow(p, sx, sy, tx, ty, w); + IF w # NIL THEN + (* (tx, ty) is point in global coordinates of target port *) + w.port.GetSize(pw, ph); + msg.x := tx * w.port.unit; + msg.y := ty * w.port.unit; + (* (msg.x, msg.y) is point in coordinates of target window *) + w.ForwardCtrlMsg(msg) + END + END Transfer; + + + (** miscellaneous **) + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + IF stdDir = NIL THEN stdDir := d END; + dir := d + END SetDir; + + PROCEDURE SelectBySpec* (loc: Files.Locator; name: Files.Name; conv: Converters.Converter; VAR done: BOOLEAN); + VAR w: Window; + BEGIN + Kernel.MakeFileName(name, ""); + w := dir.First(); + WHILE (w # NIL) & ((loc = NIL) OR (w.loc = NIL) OR (loc.res = 77) OR (w.loc.res = 77) OR + (name = "") OR (w.name = "") OR + ~Files.dir.SameFile(loc, name, w.loc, w.name) OR (w.conv # conv)) DO + w := dir.Next(w) + END; + IF w # NIL THEN dir.Select(w, lazy); done := TRUE ELSE done := FALSE END + END SelectBySpec; + + PROCEDURE SelectByTitle* (v: Views.View; flags: SET; title: Views.Title; VAR done: BOOLEAN); + VAR w: Window; t: Views.Title; n1, n2: ARRAY 64 OF CHAR; + BEGIN + done := FALSE; + IF v # NIL THEN + IF v IS Documents.Document THEN v := v(Documents.Document).ThisView() END; + Services.GetTypeName(v, n1) + ELSE n1 := "" + END; + w := dir.First(); + WHILE w # NIL DO + IF ((w.flags / flags) * {isAux, isTool} = {}) & ~(allowDuplicates IN w.flags) THEN + w.GetTitle(t); + IF t = title THEN + Services.GetTypeName(w.doc.ThisView(), n2); + IF (n1 = "") OR (n1 = n2) THEN dir.Select(w, lazy); done := TRUE; RETURN END + END + END; + w := dir.Next(w) + END + END SelectByTitle; + + + PROCEDURE (h: Hook) Omnicast (VAR msg: ANYREC); + VAR w: Window; + BEGIN + w := dir.First(); + WHILE w # NIL DO + IF ~w.sub THEN w.seq.Handle(msg) END; + w := dir.Next(w) + END + END Omnicast; + + PROCEDURE RestoreSequencer (seq: Sequencers.Sequencer); + VAR w: Window; + BEGIN + w := dir.First(); + WHILE w # NIL DO + ASSERT(w.frame # NIL, 100); + IF (seq = NIL) OR (w.seq = seq) THEN + w.Update (* causes redrawing of BlackBox region *) + END; + w := dir.Next(w) + END + END RestoreSequencer; + + PROCEDURE (h: Hook) RestoreDomain (d: Stores.Domain); + VAR seq: ANYPTR; + BEGIN + IF d = NIL THEN + RestoreSequencer(NIL) + ELSE + seq := d.GetSequencer(); + IF seq # NIL THEN + RestoreSequencer (seq(Sequencers.Sequencer)) + END + END + END RestoreDomain; + + + (* SequencerDirectory *) + + PROCEDURE (d: SequencerDirectory) New (): Sequencers.Sequencer; + BEGIN + RETURN dir.NewSequencer() + END New; + + (** CheckAction **) + + PROCEDURE (a: CheckAction) Do; + VAR w: Window; s: StdSequencer; + BEGIN + Services.DoLater(a.wait, Services.resolution); + w := dir.First(); + WHILE w # NIL DO + s := w.seq(StdSequencer); + IF s.trapEra # Kernel.trapCount THEN Reset(s) END; + ASSERT(s.nestLevel = 0, 100); + (* unbalanced calls of Views.BeginModification/EndModification or Views.BeginScript/EndScript *) + w := dir.Next(w) + END + END Do; + + PROCEDURE (a: WaitAction) Do; + BEGIN + Services.DoLater(a.check, Services.immediately) + END Do; + + + PROCEDURE (n: LangNotifier) Notify; + VAR w: Window; pw, ph: INTEGER; + BEGIN + w := dir.First(); + WHILE w # NIL DO + w.port.GetSize(pw, ph); + w.Restore(0, 0, pw, ph); + w.RefreshTitle; + w := dir.Next(w) + END + END Notify; + + PROCEDURE Init; + VAR f: Forwarder; r: Reducer; sdir: SequencerDirectory; + a: CheckAction; w: WaitAction; h: Hook; ln: LangNotifier; + BEGIN + NEW(sdir); Sequencers.SetDir(sdir); + NEW(h); Views.SetMsgHook(h); + NEW(f); Controllers.Register(f); + NEW(r); Kernel.InstallReducer(r); + NEW(a); NEW(w); a.wait := w; w.check := a; Services.DoLater(a, Services.immediately); + NEW(ln); Dialog.RegisterLangNotifier(ln) + END Init; + +BEGIN + Init +END Windows. diff --git a/Trurl-based/System/Rsrc/Strings.odc b/Trurl-based/System/Rsrc/Strings.odc new file mode 100644 index 0000000..3fd45f1 Binary files /dev/null and b/Trurl-based/System/Rsrc/Strings.odc differ diff --git a/Trurl-based/System/Rsrc/ru/Strings.odc b/Trurl-based/System/Rsrc/ru/Strings.odc new file mode 100644 index 0000000..40568a1 Binary files /dev/null and b/Trurl-based/System/Rsrc/ru/Strings.odc differ diff --git a/Trurl-based/Text/Docu/Cmds.odc b/Trurl-based/Text/Docu/Cmds.odc new file mode 100644 index 0000000..ddaf717 Binary files /dev/null and b/Trurl-based/Text/Docu/Cmds.odc differ diff --git a/Trurl-based/Text/Docu/Controllers.odc b/Trurl-based/Text/Docu/Controllers.odc new file mode 100644 index 0000000..80edd12 Binary files /dev/null and b/Trurl-based/Text/Docu/Controllers.odc differ diff --git a/Trurl-based/Text/Docu/Dev-Man.odc b/Trurl-based/Text/Docu/Dev-Man.odc new file mode 100644 index 0000000..e54ba21 Binary files /dev/null and b/Trurl-based/Text/Docu/Dev-Man.odc differ diff --git a/Trurl-based/Text/Docu/Mappers.odc b/Trurl-based/Text/Docu/Mappers.odc new file mode 100644 index 0000000..a6749e4 Binary files /dev/null and b/Trurl-based/Text/Docu/Mappers.odc differ diff --git a/Trurl-based/Text/Docu/Models.odc b/Trurl-based/Text/Docu/Models.odc new file mode 100644 index 0000000..1d1f28e Binary files /dev/null and b/Trurl-based/Text/Docu/Models.odc differ diff --git a/Trurl-based/Text/Docu/Rulers.odc b/Trurl-based/Text/Docu/Rulers.odc new file mode 100644 index 0000000..80fc40b Binary files /dev/null and b/Trurl-based/Text/Docu/Rulers.odc differ diff --git a/Trurl-based/Text/Docu/Setters.odc b/Trurl-based/Text/Docu/Setters.odc new file mode 100644 index 0000000..7749170 Binary files /dev/null and b/Trurl-based/Text/Docu/Setters.odc differ diff --git a/Trurl-based/Text/Docu/Sys-Map.odc b/Trurl-based/Text/Docu/Sys-Map.odc new file mode 100644 index 0000000..86ccafc Binary files /dev/null and b/Trurl-based/Text/Docu/Sys-Map.odc differ diff --git a/Trurl-based/Text/Docu/User-Man.odc b/Trurl-based/Text/Docu/User-Man.odc new file mode 100644 index 0000000..c815589 Binary files /dev/null and b/Trurl-based/Text/Docu/User-Man.odc differ diff --git a/Trurl-based/Text/Docu/Views.odc b/Trurl-based/Text/Docu/Views.odc new file mode 100644 index 0000000..246a196 Binary files /dev/null and b/Trurl-based/Text/Docu/Views.odc differ diff --git a/Trurl-based/Text/Mod/Cmds.odc b/Trurl-based/Text/Mod/Cmds.odc new file mode 100644 index 0000000..b49b917 Binary files /dev/null and b/Trurl-based/Text/Mod/Cmds.odc differ diff --git a/Trurl-based/Text/Mod/Cmds.txt b/Trurl-based/Text/Mod/Cmds.txt new file mode 100644 index 0000000..1966552 --- /dev/null +++ b/Trurl-based/Text/Mod/Cmds.txt @@ -0,0 +1,860 @@ +MODULE TextCmds; + + (* THIS IS TEXT COPY OF BlackBox Text/Mod/Cmds.odc *) + (* DO NOT EDIT *) + +(* could eliminate ReplList/ReplOp and use Models.Begin/EndScript instead (as already done for shifting) *) +(* move ListAlienViews to StdCmds and generalize accordingly? *) + + + IMPORT + Strings, Ports, Stores, Models, Views, Controllers, Properties, Dialog, Containers, + TextModels, TextMappers, TextRulers, TextSetters, TextViews, TextControllers; + + CONST + (* ShiftOp.left *) + left = TRUE; right = FALSE; + + (* PreparePat, FindPat *) + leftTerm = 3X; rightTerm = 4X; + + (* DoReplace mode *) + replace = 0; replaceAndFind = 1; replaceAll = 2; + + (* FindIn first *) + first = TRUE; again = FALSE; + + mm = Ports.mm; point = Ports.point; maxPat = 256; + viewcode = TextModels.viewcode; + tab = TextModels.tab; line = TextModels.line; para = TextModels.para; + nbspace = TextModels.nbspace; digitspace = TextModels.digitspace; + hyphen = TextModels.hyphen; + nbhyphen = TextModels.nbhyphen; softhyphen = TextModels.softhyphen; + + posKey = "#Text:Position"; + searchAliensKey = "#Text:SearchForAlienViews"; (* dormant code option *) + alienTypeKey = "#Text:AlienViewType"; + noAliensKey = "#Text:NoAlienViewsFound"; + noRulerKey = "#Text:NoRulerSelected"; + noMatchKey = "#Text:SelectionDoesNotMatch"; + noTargetKey = "#Text:NoTargetFound"; + noSelectionKey = "#Text:NoSelectionFound"; + noPatternKey = "#Text:PatternNotSpecified"; + notFoundKey = "#Text:PatternNotFound"; (* not used *) + replacingKey = "#System:Replacing"; + shiftingKey = "#Text:Shifting"; + showMarksKey = "#Text:ShowMarks"; + hideMarksKey = "#Text:HideMarks"; + replaceSelectionKey = "#Text:ReplaceAllInSelection"; + replaceAllKey = "#Text:ReplaceAll"; + + + TYPE + FindSpec = RECORD + valid, ignoreCase, wordBeginsWith, wordEndsWith, reverse: BOOLEAN; + start: INTEGER; + find: ARRAY maxPat OF CHAR + END; + + ReplList = POINTER TO RECORD + next: ReplList; + beg, end: INTEGER; + buf: TextModels.Model + END; + + ReplOp = POINTER TO RECORD (Stores.Operation) + text: TextModels.Model; + list, last: ReplList; + find: FindSpec + END; + + + VAR + find*: RECORD + find*: ARRAY maxPat OF CHAR; + replace*: ARRAY maxPat OF CHAR; + ignoreCase*, wordBeginsWith*, wordEndsWith*: BOOLEAN; + reverseOrientation*: BOOLEAN + END; + + ruler*: RECORD + pageBreaks*: RECORD + notInside*, joinPara*: BOOLEAN + END + END; + + + PROCEDURE Show (t: TextModels.Model; beg, end: INTEGER); + BEGIN + TextViews.ShowRange(t, beg, end, TextViews.focusOnly); + IF beg = end THEN + TextControllers.SetCaret(t, beg) + ELSE + TextControllers.SetSelection(t, beg, end) + END + END Show; + + PROCEDURE NoShow (t: TextModels.Model; pos: INTEGER); + BEGIN + TextControllers.SetSelection(t, pos, pos); + TextControllers.SetCaret(t, pos) + END NoShow; + + PROCEDURE Ruler (): TextRulers.Ruler; + VAR r: TextRulers.Ruler; + BEGIN + r := TextRulers.dir.New(NIL); + TextRulers.AddTab(r, 4*mm); TextRulers.AddTab(r, 20*mm); + RETURN r + END Ruler; + + + (* search & replace *) + + PROCEDURE LeftTerminator (ch: CHAR): BOOLEAN; + BEGIN + IF ch < 100X THEN + CASE ch OF + viewcode, tab, line, para, " ", + "(", "[", "{", "=", + hyphen, softhyphen: RETURN TRUE + ELSE RETURN FALSE + END + ELSE RETURN TRUE + END + END LeftTerminator; + + PROCEDURE RightTerminator (ch: CHAR): BOOLEAN; + BEGIN + IF ch < 100X THEN + CASE ch OF + 0X, viewcode, tab, line, para, " ", + "!", "(", ")", ",", ".", ":", ";", "?", "[", "]", "{", "}", + hyphen, softhyphen: RETURN TRUE + ELSE RETURN FALSE + END + ELSE RETURN TRUE + END + END RightTerminator; + + PROCEDURE PreparePat (spec: FindSpec; + VAR pat: ARRAY OF CHAR; VAR n: INTEGER; + VAR wordBeg, wordEnd: BOOLEAN); + VAR i: INTEGER; ch: CHAR; + BEGIN + i := 0; ch := spec.find[0]; + wordBeg := spec.wordBeginsWith & ~LeftTerminator(ch); + IF wordBeg THEN pat[0] := leftTerm; n := 1 ELSE n := 0 END; + WHILE ch # 0X DO + IF ch # softhyphen THEN + IF spec.ignoreCase THEN pat[n] := Strings.Upper(ch) ELSE pat[n] := ch END; + INC(n) + END; + INC(i); ch := spec.find[i] + END; + wordEnd := spec.wordEndsWith & ~RightTerminator(pat[n - 1]); + IF wordEnd THEN pat[n] := rightTerm; INC(n) END + END PreparePat; + + PROCEDURE FindPat (t: TextModels.Model; spec: FindSpec; VAR beg, end: INTEGER); + (* post: beg < end => t[beg, end) = spec.find, start <= beg; else beg = end *) + VAR r: TextModels.Reader; start: INTEGER; + i, j, b, e, n: INTEGER; ch0, ch, ch1: CHAR; wordBeg, wordEnd, icase: BOOLEAN; + pat, ref: ARRAY maxPat OF CHAR; (* ref [b..e) is readback buffer *) + pos0, pos1, absStart: INTEGER; + orientation: INTEGER; + BEGIN + IF spec.reverse THEN + orientation := -1; absStart := t.Length(); + PreparePat(spec, ref, n, wordEnd, wordBeg); + i := n; j := 0; REPEAT DEC(i); pat[j] := ref[i]; INC(j) UNTIL i = 0 (* Just reverse the pattern... *) + ELSE + orientation := 1; absStart := 0; + PreparePat(spec, pat, n, wordBeg, wordEnd) + END; + start := spec.start; icase := spec.ignoreCase; + r := t.NewReader(NIL); i := 0; + IF wordBeg THEN + IF start # absStart THEN + DEC(start, orientation) + ELSE + r.SetPos(absStart); + IF spec.reverse THEN r.ReadPrevChar(ch) ELSE r.ReadChar(ch) END; + IF ~LeftTerminator(ch) THEN i := 1 END + END + END; + r.SetPos(start); IF spec.reverse THEN r.ReadPrevChar(ch) ELSE r.ReadChar(ch) END; + pos0 := start; pos1 := start; + IF icase THEN ch := Strings.Upper(ch) END; + ref[0] := ch; ch0 := ch; j := 0; b := 0; e := 1; + WHILE ~r.eot & (i < n) DO + ch1 := pat[i]; + IF (ch1 = ch) + OR (ch1 = leftTerm) & LeftTerminator(ch) + OR (ch1 = rightTerm) & RightTerminator(ch) THEN + INC(i); j := (j + 1) MOD maxPat + ELSIF ch = softhyphen THEN + j := (j + 1) MOD maxPat + ELSE + i := 0; INC(pos0, orientation); b := (b + 1) MOD maxPat; j := b + END; + IF j # e THEN + ch := ref[j] + ELSE + INC(pos1, orientation); + IF spec.reverse THEN r.ReadPrevChar(ch) ELSE r.ReadChar(ch) END; + IF icase THEN ch := Strings.Upper(ch) END; + ref[j] := ch; e := (e + 1) MOD maxPat + END + END; + IF wordEnd & ~((i + 1 = n) & r.eot) THEN DEC(pos1, orientation) END; + IF (n > 0) & ((i = n) OR wordEnd & (i + 1 = n) & r.eot) THEN + IF wordBeg & ((pos0 # absStart) OR LeftTerminator(ch0)) THEN INC(pos0, orientation) END + ELSE + pos0 := pos1 + END; + IF spec.reverse THEN + beg := pos1; end := pos0 + ELSE + beg := pos0; end := pos1 + END + END FindPat; + + PROCEDURE OverrideSpecWithOption (VAR spec: FindSpec; option: ARRAY OF CHAR); + VAR i: INTEGER; choice: BOOLEAN; ch: CHAR; + BEGIN + choice := TRUE; i := 0; ch := option[i]; + WHILE ch # 0X DO + CASE option[i] OF + '~': choice := ~choice + | 'I', 'i': spec.ignoreCase := choice; choice := TRUE + | 'B', 'b': spec.wordBeginsWith := choice; choice := TRUE + | 'E', 'e': spec.wordEndsWith := choice; choice := TRUE + | 'R', 'r': spec.reverse := choice; choice := TRUE + ELSE choice := TRUE + END; + INC(i); ch := option[i] + END + END OverrideSpecWithOption; + + PROCEDURE SetSpec (VAR spec: FindSpec; pos0, pos1: INTEGER; option: ARRAY OF CHAR); + BEGIN + ASSERT(find.find # "", 20); + spec.valid := TRUE; + spec.ignoreCase := find.ignoreCase; + spec.wordBeginsWith := find.wordBeginsWith; + spec.wordEndsWith := find.wordEndsWith; + spec.reverse := find.reverseOrientation; + OverrideSpecWithOption(spec, option); + IF spec.reverse THEN spec.start := pos1 + ELSE spec.start := pos0 + END; + spec.find := find.find$ + END SetSpec; + + PROCEDURE SetFindSpec (c: TextControllers.Controller; first: BOOLEAN; option: ARRAY OF CHAR; + VAR spec: FindSpec + ); + VAR (*start,*) pos0, pos1, beg, end: INTEGER; + BEGIN + IF first THEN pos0 := 0; pos1 := pos0 + ELSIF c.HasCaret() THEN pos0 := c.CaretPos(); pos1 := pos0 + ELSIF c.HasSelection() THEN c.GetSelection(beg, end); pos0 := beg + 1; pos1 := end - 1 + ELSE pos0 := 0; pos1 := pos0 + END; + SetSpec(spec, pos0, pos1, option); + IF spec.reverse THEN + IF spec.start = 0 THEN spec.start := c.text.Length() END + ELSE + IF spec.start = c.text.Length() THEN spec.start := 0 END + END + END SetFindSpec; + + + PROCEDURE ReplBuf (target: TextModels.Model; pos: INTEGER): TextModels.Model; + VAR buf: TextModels.Model; attr: TextModels.Attributes; rd: TextModels.Reader; + out: TextModels.Writer; i: INTEGER; + BEGIN + rd := target.NewReader(NIL); rd.SetPos(pos); rd.ReadRun(attr); + buf := TextModels.CloneOf(target); out := buf.NewWriter(NIL); out.SetPos(0); + IF attr # NIL THEN out.SetAttr(attr) END; + i := 0; WHILE find.replace[i] # 0X DO out.WriteChar(find.replace[i]); INC(i) END; + RETURN buf + END ReplBuf; + + + (* operations *) + + PROCEDURE (op: ReplOp) Do; + VAR u, v: ReplList; text, save: TextModels.Model; beg, end, delta, len: INTEGER; + BEGIN + text := op.text; + u := op.list; v := NIL; delta := 0; + WHILE u # NIL DO + INC(u.beg, delta); INC(u.end, delta); + IF u.end > u.beg THEN + save := TextModels.CloneOf(text); save.Insert(0, text, u.beg, u.end); + DEC(delta, u.end - u.beg) + ELSE + save := NIL + END; + IF u.buf # NIL THEN + len := u.buf.Length(); + text.Insert(u.beg, u.buf, 0, len); + u.end := u.beg + len; + INC(delta, len) + ELSE + u.end := u.beg + END; + u.buf := save; + v := u; u := u.next + END; + IF op.find.valid THEN + FindPat(text, op.find, beg, end); op.find.valid := FALSE; + IF beg = end THEN Dialog.Beep END + ELSIF v # NIL THEN + beg := v.beg; end := v.end + ELSE + beg := 0; end := 0 + END; + IF end > beg THEN Show(text, beg, end) ELSE NoShow(text, beg) END + END Do; + + PROCEDURE AddRepl (op: ReplOp; beg, end: INTEGER; reverse: BOOLEAN); + VAR u: ReplList; + BEGIN + NEW(u); u.beg := beg; u.end := end; u.buf := ReplBuf(op.text, beg); + IF reverse THEN (* append *) + u.next := op.list; op.list := u + ELSE (* prepend *) + IF op.list = NIL THEN op.list := u ELSE op.last.next := u END; + op.last := u + END + END AddRepl; + + PROCEDURE DoReplaceThis ( + t: TextModels.Model; mode: INTEGER; + firstBeg, firstEnd: INTEGER; + rngBeg, rngEnd: INTEGER; + option: ARRAY OF CHAR + ); + VAR op: ReplOp; spec: FindSpec; beg, end, len: INTEGER; + BEGIN + NEW(op); op.text := t; op.list := NIL; + beg := firstBeg; end := firstEnd; + IF mode IN {replace, replaceAndFind} THEN + AddRepl(op, firstBeg, firstEnd, spec.reverse) + END; + IF mode = replaceAndFind THEN + SetSpec(op.find, firstBeg + (* LEN(find.replace$) *) ReplBuf(t, 0).Length(), firstBeg, option) + ELSE + op.find.valid := FALSE + END; + IF mode = replaceAll THEN + len := LEN(find.find$); + SetSpec(spec, 0, t.Length(), option); + WHILE (rngBeg <= beg) & (beg < end) & (end <= rngEnd) DO + AddRepl(op, beg, end, spec.reverse); + IF spec.reverse THEN spec.start := beg ELSE spec.start := beg + len END; + FindPat(t, spec, beg, end) + END + END; + Models.Do(t, replacingKey, op) + END DoReplaceThis; + + PROCEDURE DoReplace (c: TextControllers.Controller; mode: INTEGER; option: ARRAY OF CHAR); + VAR t: TextModels.Model; spec: FindSpec; + selBeg, selEnd, beg, end, len0: INTEGER; hasSel0: BOOLEAN; + BEGIN + IF c # NIL THEN + t := c.text; len0 := t.Length(); hasSel0 := c.HasSelection(); + IF hasSel0 THEN + c.GetSelection(selBeg, selEnd); + IF selEnd < len0 THEN + SetSpec(spec, selBeg, selEnd + 1, option) + ELSE SetSpec(spec, selBeg, selEnd, option) + END + ELSE + selBeg := 0; selEnd := len0; + SetFindSpec(c, (* again *) mode = replaceAll, option, spec) + END; + FindPat(t, spec, beg, end); + IF mode = replaceAll THEN + IF (selBeg <= beg) & (beg < end) & (end <= selEnd) THEN + DoReplaceThis(t, mode, beg, end, selBeg, selEnd, option); + IF hasSel0 THEN Show(c.text, selBeg, selEnd + t.Length() - len0) END + ELSE NoShow(c.text, 0); Dialog.Beep + END + ELSIF hasSel0 THEN + IF (beg = selBeg) & (end = selEnd) THEN + DoReplaceThis(t, mode, selBeg, selEnd, 0, len0, option) + ELSE Dialog.ShowParamMsg(noMatchKey, spec.find, "", "") + END + ELSE Dialog.ShowMsg(noSelectionKey) + END + ELSE Dialog.ShowMsg(noTargetKey) + END + END DoReplace; + + PROCEDURE DoShift (c: TextControllers.Controller; left: BOOLEAN); + VAR script: Stores.Operation; + t: TextModels.Model; st: TextSetters.Setter; + rd: TextModels.Reader; wr: TextModels.Writer; + box: TextSetters.LineBox; beg, pos, end: INTEGER; ch: CHAR; + BEGIN + IF (c # NIL) & (c.HasSelection() OR c.HasCaret()) THEN + t := c.text; + IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := c.CaretPos(); end := beg END; + st := c.view.ThisSetter(); beg := st.ThisSequence(beg); pos := beg; + rd := t.NewReader(NIL); rd.SetPos(pos); + IF ~left THEN wr := t.NewWriter(NIL) END; + Models.BeginScript(t, shiftingKey, script); + REPEAT + rd.ReadChar(ch); + IF rd.view # NIL THEN + st.GetLine(pos, box); + IF box.rbox THEN ch := para END + END; + IF left & ((ch = tab) OR (ch = " ") OR (ch = digitspace) OR (ch = nbspace)) THEN + t.Delete(pos, pos + 1); rd.SetPos(pos); DEC(end) + ELSIF ~left & (ch # line) & (ch # para) THEN + wr.SetPos(pos); + IF (ch = " ") OR (ch = digitspace) OR (ch = nbspace) THEN + wr.WriteChar(ch) + ELSE wr.WriteChar(tab) + END; + INC(pos); INC(end) + ELSE INC(pos) + END; + WHILE ~rd.eot & (ch # line) & (ch # para) DO + INC(pos); rd.ReadChar(ch) + END + UNTIL rd.eot OR (pos >= end); + Models.EndScript(t, script); + IF end > beg THEN TextControllers.SetSelection(t, beg, end) END + END + END DoShift; + + (** commands **) + + PROCEDURE ListAlienViews*; + VAR t: TextModels.Model; v: TextViews.View; wr: TextMappers.Formatter; + rd: TextModels.Reader; view: Views.View; + type: Stores.TypeName; none: BOOLEAN; + BEGIN + t := TextViews.FocusText(); + IF t # NIL THEN + wr.ConnectTo(TextModels.dir.New()); + rd := t.NewReader(NIL); rd.ReadView(view); none := TRUE; + WHILE view # NIL DO + IF view IS Views.Alien THEN + IF none THEN + wr.WriteTab; wr.WriteMsg(posKey); + wr.WriteTab; wr.WriteMsg(alienTypeKey); wr.WriteLn + END; + none := FALSE; + type := view(Views.Alien).store.path[0]$; + wr.WriteTab; + wr.WriteIntForm(rd.Pos() - 1, + TextMappers.decimal, 5, nbspace, TextMappers.hideBase); + wr.WriteTab; wr.WriteString(type); wr.WriteLn + END; + rd.ReadView(view) + END; + IF none THEN wr.WriteString(noAliensKey); wr.WriteLn END; + v := TextViews.dir.New(wr.rider.Base()); + v.SetDefaults(Ruler(), TextViews.dir.defAttr); + Views.OpenView(v) + END + END ListAlienViews; + + + PROCEDURE ToggleMarksGuard* (VAR par: Dialog.Par); + VAR v: TextViews.View; + BEGIN + v := TextViews.Focus(); + IF (v # NIL) & v.HidesMarks() THEN par.label := showMarksKey + ELSE par.label := hideMarksKey + END + END ToggleMarksGuard; + + PROCEDURE ToggleMarks*; + VAR v: TextViews.View; + BEGIN + v := TextViews.Focus(); + IF v # NIL THEN v.DisplayMarks(~v.HidesMarks()) END + END ToggleMarks; + + PROCEDURE ShowMarks*; + VAR v: TextViews.View; + BEGIN + v := TextViews.Focus(); + IF (v # NIL) & v.HidesMarks() THEN v.DisplayMarks(TextViews.show) END + END ShowMarks; + + PROCEDURE HideMarks*; + VAR v: TextViews.View; + BEGIN + v := TextViews.Focus(); + IF (v # NIL) & ~v.HidesMarks() THEN v.DisplayMarks(TextViews.hide) END + END HideMarks; + + PROCEDURE MakeDefaultRulerGuard* (VAR par: Dialog.Par); + VAR c: TextControllers.Controller; v: Views.View; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + v := c.Singleton(); + IF (v = NIL) OR ~(v IS TextRulers.Ruler) THEN par.disabled := TRUE END + ELSE par.disabled := TRUE + END + END MakeDefaultRulerGuard; + + PROCEDURE MakeDefaultRuler*; + VAR c: TextControllers.Controller; rd: TextModels.Reader; + r: TextRulers.Ruler; a: TextModels.Attributes; + beg, end: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + IF c.HasSelection() THEN + c.GetSelection(beg, end); + rd := c.text.NewReader(NIL); rd.SetPos(beg); rd.Read; + IF (rd.view # NIL) & (rd.view IS TextRulers.Ruler) THEN + c.view.PollDefaults(r, a); + c.view.SetDefaults(rd.view(TextRulers.Ruler), a) + ELSE Dialog.ShowMsg(noRulerKey) + END + ELSE Dialog.ShowMsg(noSelectionKey) + END + ELSE Dialog.ShowMsg(noTargetKey) + END + END MakeDefaultRuler; + + PROCEDURE MakeDefaultAttributes*; + VAR c: TextControllers.Controller; rd: TextModels.Reader; + r: TextRulers.Ruler; a: TextModels.Attributes; + beg, end: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + IF c.HasSelection() THEN + c.GetSelection(beg, end); + rd := c.text.NewReader(NIL); rd.SetPos(beg); rd.Read; + c.view.PollDefaults(r, a); + c.view.SetDefaults(r, rd.attr) + ELSE Dialog.ShowMsg(noSelectionKey) + END + ELSE Dialog.ShowMsg(noTargetKey) + END + END MakeDefaultAttributes; + + PROCEDURE ShiftLeft*; + BEGIN + DoShift(TextControllers.Focus(), left) + END ShiftLeft; + + PROCEDURE ShiftRight*; + BEGIN + DoShift(TextControllers.Focus(), right) + END ShiftRight; + + + PROCEDURE Subscript*; + VAR q, p0: Properties.Property; p: TextModels.Prop; + BEGIN + Properties.CollectProp(q); + p0 := q; WHILE (p0 # NIL) & ~(p0 IS TextModels.Prop) DO p0 := p0.next END; + NEW(p); p.valid := {TextModels.offset}; + IF (p0 # NIL) & (TextModels.offset IN p0.valid) THEN + p.offset := p0(TextModels.Prop).offset - point + ELSE p.offset := -point + END; + Properties.EmitProp(NIL, p) + END Subscript; + + PROCEDURE Superscript*; + VAR q, p0: Properties.Property; p: TextModels.Prop; + BEGIN + Properties.CollectProp(q); + p0 := q; WHILE (p0 # NIL) & ~(p0 IS TextModels.Prop) DO p0 := p0.next END; + NEW(p); p.valid := {TextModels.offset}; + IF (p0 # NIL) & (TextModels.offset IN p0.valid) THEN + p.offset := p0(TextModels.Prop).offset + point + ELSE p.offset := point + END; + Properties.EmitProp(NIL, p) + END Superscript; + + + PROCEDURE ForceToNewLine (c: TextControllers.Controller); + VAR st: TextSetters.Setter; pos, start: INTEGER; msg: Controllers.EditMsg; + BEGIN + IF c.HasCaret() THEN + pos := c.CaretPos(); + st := c.view.ThisSetter(); start := st.ThisLine(pos); + IF pos # start THEN + msg.op := Controllers.pasteChar; msg.char := line; + Controllers.Forward(msg) + END + END + END ForceToNewLine; + + PROCEDURE InsertParagraph*; + VAR c: TextControllers.Controller; script: Stores.Operation; msg: Controllers.EditMsg; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + Models.BeginScript(c.text, "#Text:InsertParagraph", script); + ForceToNewLine(c); + msg.op := Controllers.pasteChar; msg.char := para; + Controllers.Forward(msg); + Models.EndScript(c.text, script) + END + END InsertParagraph; + + PROCEDURE InsertRuler*; + VAR c: TextControllers.Controller; script: Stores.Operation; + rd: TextModels.Reader; r: TextRulers.Ruler; + pos, end: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + r := NIL; + IF c.HasSelection() THEN + c.GetSelection(pos, end); + rd := c.text.NewReader(NIL); rd.SetPos(pos); rd.Read; + IF (rd.view # NIL) & (rd.view IS TextRulers.Ruler) THEN + r := rd.view(TextRulers.Ruler) + END + ELSE pos := c.CaretPos() + END; + IF r = NIL THEN r := TextViews.ThisRuler(c.view, pos) END; + r := TextRulers.CopyOf(r, Views.deep); + Models.BeginScript(c.text, "#Text:InsertRuler", script); + ForceToNewLine(c); + c.view.DisplayMarks(TextViews.show); + Controllers.PasteView(r, Views.undefined, Views.undefined, FALSE); + Models.EndScript(c.text, script) + END + END InsertRuler; + + PROCEDURE InsertSoftHyphen*; + VAR msg: Controllers.EditMsg; + BEGIN + msg.op := Controllers.pasteChar; msg.char := softhyphen; + Controllers.Forward(msg) + END InsertSoftHyphen; + + PROCEDURE InsertNBHyphen*; + VAR msg: Controllers.EditMsg; + BEGIN + msg.op := Controllers.pasteChar; msg.char := nbhyphen; + Controllers.Forward(msg) + END InsertNBHyphen; + + PROCEDURE InsertNBSpace*; + VAR msg: Controllers.EditMsg; + BEGIN + msg.op := Controllers.pasteChar; msg.char := nbspace; + Controllers.Forward(msg) + END InsertNBSpace; + + PROCEDURE InsertDigitSpace*; + VAR msg: Controllers.EditMsg; + BEGIN + msg.op := Controllers.pasteChar; msg.char := digitspace; + Controllers.Forward(msg) + END InsertDigitSpace; + + + PROCEDURE GetFindPattern (c: TextControllers.Controller); + VAR r: TextModels.Reader; beg, end: INTEGER; i: INTEGER; ch: CHAR; + new: ARRAY maxPat OF CHAR; + BEGIN + IF (c # NIL) & c.HasSelection() THEN + c.GetSelection(beg, end); + r := c.text.NewReader(NIL); r.SetPos(beg); r.ReadChar(ch); i := 0; + WHILE (r.Pos() <= end) & (i < maxPat - 1) DO + new[i] := ch; INC(i); r.ReadChar(ch) + END; + new[i] := 0X; + IF (new # "") & (new # find.find) THEN + find.find := new$; + find.ignoreCase := FALSE; + find.wordBeginsWith := FALSE; find.wordEndsWith := FALSE; + Dialog.Update(find) + END + END + END GetFindPattern; + + PROCEDURE FindIn (c: TextControllers.Controller; first: BOOLEAN; option: ARRAY OF CHAR); + VAR spec: FindSpec; beg, end: INTEGER; + BEGIN + IF c # NIL THEN + IF find.find # "" THEN + SetFindSpec(c, first, option, spec); + FindPat(c.text, spec, beg, end); + IF end > beg THEN Show(c.text, beg, end) ELSE NoShow(c.text, 0); Dialog.Beep END + ELSE Dialog.ShowMsg(noPatternKey) + END + ELSE Dialog.ShowMsg(noTargetKey) + END + END FindIn; + + + PROCEDURE FindGuard* (VAR par: Dialog.Par); + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (find.find = "") THEN par.disabled := TRUE END + END FindGuard; + + PROCEDURE FindFirst* (option: ARRAY OF CHAR); + BEGIN + FindIn(TextControllers.Focus(), first, option) + END FindFirst; + + PROCEDURE FindAgainGuard* (VAR par: Dialog.Par); + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (~c.HasSelection() & (find.find = "")) THEN par.disabled := TRUE END + END FindAgainGuard; + + PROCEDURE FindAgain* (option: ARRAY OF CHAR); + BEGIN + FindIn(TextControllers.Focus(), again, option) + END FindAgain; + + + PROCEDURE ReplaceGuard* (VAR par: Dialog.Par); + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (Containers.noCaret IN c.opts) OR ~c.HasSelection() OR (find.find = "") THEN + par.disabled := TRUE + END + END ReplaceGuard; + + PROCEDURE Replace* (option: ARRAY OF CHAR); + BEGIN + DoReplace(TextControllers.Focus(), replace, option) + END Replace; + + PROCEDURE ReplaceAndFindNext* (option: ARRAY OF CHAR); + BEGIN + DoReplace(TextControllers.Focus(), replaceAndFind, option) + END ReplaceAndFindNext; + + + PROCEDURE ReplaceAllGuard* (VAR par: Dialog.Par); + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (Containers.noCaret IN c.opts) OR (find.find = "") THEN + par.disabled := TRUE + ELSE + IF c.HasSelection() THEN par.label := replaceSelectionKey ELSE par.label := replaceAllKey END + END + END ReplaceAllGuard; + + PROCEDURE ReplaceAll* (option: ARRAY OF CHAR); + BEGIN + DoReplace(TextControllers.Focus(), replaceAll, option) + END ReplaceAll; + + + PROCEDURE SetNormalOrientation*; + BEGIN + find.reverseOrientation := FALSE; + Dialog.Update(find) + END SetNormalOrientation; + + PROCEDURE SetReverseOrientation*; + BEGIN + find.reverseOrientation := TRUE; + Dialog.Update(find) + END SetReverseOrientation; + + PROCEDURE InitFindDialog*; + BEGIN + GetFindPattern(TextControllers.Focus()) + END InitFindDialog; + + + (** ruler dialog **) + + PROCEDURE InitRulerDialog*; + VAR v: Views.View; ra: TextRulers.Attributes; + BEGIN + v := Controllers.FocusView(); + IF v # NIL THEN + WITH v: TextRulers.Ruler DO + ra := v.style.attr; + ruler.pageBreaks.notInside := TextRulers.noBreakInside IN ra.opts; + ruler.pageBreaks.joinPara := TextRulers.parJoin IN ra.opts + ELSE + END + END + END InitRulerDialog; + + PROCEDURE SetRuler*; + VAR v: Views.View; p: TextRulers.Prop; + BEGIN + v := Controllers.FocusView(); + IF v # NIL THEN + WITH v: TextRulers.Ruler DO + NEW(p); p.valid := {TextRulers.opts}; + p.opts.mask := {TextRulers.noBreakInside, TextRulers.parJoin}; + p.opts.val := {}; + IF ruler.pageBreaks.notInside THEN INCL(p.opts.val, TextRulers.noBreakInside) END; + IF ruler.pageBreaks.joinPara THEN INCL(p.opts.val, TextRulers.parJoin) END; + Properties.EmitProp(NIL, p) + ELSE + END + END + END SetRuler; + + + (** standard text-related guards **) + + PROCEDURE FocusGuard* (VAR par: Dialog.Par); + (** in non-TextView menus; otherwise implied by menu type **) + BEGIN + IF TextViews.Focus() = NIL THEN par.disabled := TRUE END + END FocusGuard; + + PROCEDURE EditGuard* (VAR par: Dialog.Par); + (** in non-TextView menus; otherwise use "StdCmds.EditGuard" **) + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (Containers.noCaret IN c.opts) THEN par.disabled := TRUE END + END EditGuard; + + PROCEDURE SelectionGuard* (VAR par: Dialog.Par); + (** in non-TextView menus; otherwise use "StdCmds.SelectionGuard" **) + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR ~c.HasSelection() THEN par.disabled := TRUE END + END SelectionGuard; + + PROCEDURE EditSelectionGuard* (VAR par: Dialog.Par); + (** in non-TextView menus; otherwise use "StdCmds.SelectionGuard" **) + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (Containers.noCaret IN c.opts) OR ~c.HasSelection() THEN par.disabled := TRUE END + END EditSelectionGuard; + + PROCEDURE SingletonGuard* (VAR par: Dialog.Par); + (** in non-TextView menus; otherwise use "StdCmds.SingletonGuard" **) + VAR c: TextControllers.Controller; + BEGIN + c := TextControllers.Focus(); + IF (c = NIL) OR (c.Singleton() = NIL) THEN par.disabled := TRUE END + END SingletonGuard; + +END TextCmds. diff --git a/Trurl-based/Text/Mod/Controllers.odc b/Trurl-based/Text/Mod/Controllers.odc new file mode 100644 index 0000000..70b1790 Binary files /dev/null and b/Trurl-based/Text/Mod/Controllers.odc differ diff --git a/Trurl-based/Text/Mod/Controllers.txt b/Trurl-based/Text/Mod/Controllers.txt new file mode 100644 index 0000000..470727e --- /dev/null +++ b/Trurl-based/Text/Mod/Controllers.txt @@ -0,0 +1,1633 @@ +MODULE TextControllers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Controllers.odc *) + (* DO NOT EDIT *) + + IMPORT + Services, Stores, Ports, Models, Views, Dialog, Controllers, Properties, Containers, + TextModels, TextRulers, TextSetters, TextViews; + + CONST + noAutoScroll* = 16; noAutoIndent* = 17; + + (** Controller.SetCaret pos; Controller.SetSelection beg, end **) + none* = -1; + + (* Track mode *) + chars = 0; words = 1; lines = 2; (* plus "none", defined above *) + + enter = 3X; rdel = 7X; ldel = 8X; + aL = 1CX; aR = 1DX; aU = 1EX; aD = 1FX; + pL = 10X; pR = 11X; pU = 12X; pD = 13X; + dL = 14X; dR = 15X; dU = 16X; dD = 17X; + + viewcode = TextModels.viewcode; + tab = TextModels.tab; line = TextModels.line; para = TextModels.para; + + point = Ports.point; mm = Ports.mm; inch16 = Ports.inch DIV 16; + + boundCaret = TRUE; + lenCutoff = 2000; (* max run length inspected to fetch properties *) + + attrChangeKey = "#Text:AttributeChange"; + resizingKey = "#System:Resizing"; + insertingKey = "#System:Inserting"; + deletingKey = "#System:Deleting"; + movingKey = "#System:Moving"; + copyingKey = "#System:Copying"; + linkingKey = "#System:Linking"; + replacingKey = "#System:Replacing"; + + minVersion = 0; maxVersion = 0; maxStdVersion = 0; + + + TYPE + Controller* = POINTER TO ABSTRACT RECORD (Containers.Controller) + view-: TextViews.View; + text-: TextModels.Model (** view # NIL => text = view.ThisText() **) + END; + + Directory* = POINTER TO ABSTRACT RECORD (Containers.Directory) END; + + + FilterPref* = RECORD (Properties.Preference) + controller*: Controller; (** IN, set to text controller asking for filter **) + frame*: Views.Frame; (** IN, set to frame of controlled text view **) + x*, y*: INTEGER; (** IN, set to coordinates of cursor in frame space **) + filter*: BOOLEAN (** preset to FALSE **) + END; + + FilterPollCursorMsg* = RECORD (Controllers.Message) + controller*: Controller; (** IN, set to text controller asking for filter **) + x*, y*: INTEGER; + cursor*: INTEGER; (** as for Controllers.PollCursorMsg **) + done*: BOOLEAN (** OUT; initialized to FALSE **) + END; + + FilterTrackMsg* = RECORD (Controllers.Message) + controller*: Controller; (** IN, set to text controller asking for filter **) + x*, y*: INTEGER; + modifiers*: SET; (** as for Controllers.TrackMsg **) + done*: BOOLEAN (** OUT; initialized to FALSE **) + END; + + + StdCtrl = POINTER TO RECORD (Controller) + (* general state *) + cachedRd: TextModels.Reader; + cachedWr: TextModels.Writer; + insAttr: TextModels.Attributes; (* preset attrs for next typed char *) + autoBeg, autoEnd: INTEGER; (* lazy auto-scrolling; + invalid if (-1, .); initially (MAX(LONGINT), 0) *) + (* caret *) + carPos: INTEGER; (* HasCaret() iff 0 <= carPos <= text.Length() *) + carLast: INTEGER; (* used to recover caret at meaningful position *) + carX, lastX: INTEGER; (* arrow up/down anti-aliasing *) + carTick: LONGINT; (* next tick to invert flashing caret mark *) + carVisible: BOOLEAN; (* caret currently visible - used for flashing caret *) + (* selection *) + selBeg, selEnd: INTEGER; (* HasSel() iff 0 <= selBeg < selEnd <= text.Length() *) + aliasSelBeg, aliasSelEnd: INTEGER; (* need lazy synchronization? *) + selPin0, selPin1: INTEGER; (* anchor points of selection *) + (* most recent scroll-while-tracking step *) + lastStep: LONGINT + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + + (* messages *) + + ModelMessage* = ABSTRACT RECORD (Models.Message) END; + (** messages to control virtual model extensions, such as marks **) + + SetCaretMsg* = EXTENSIBLE RECORD (ModelMessage) + pos*: INTEGER + END; + + SetSelectionMsg* = EXTENSIBLE RECORD (ModelMessage) + beg*, end*: INTEGER + END; + + + ViewMessage = ABSTRACT RECORD (Views.Message) END; + + CaretMsg = RECORD (ViewMessage) + show: BOOLEAN + END; + + SelectionMsg = RECORD (ViewMessage) + beg, end: INTEGER; + show: BOOLEAN + END; + + + (* miscellaneous *) + + TrackState = RECORD + x, y: INTEGER; + toggle: BOOLEAN + END; + + + VAR + dir-, stdDir-: Directory; + + + PROCEDURE CachedReader (c: StdCtrl): TextModels.Reader; + VAR rd: TextModels.Reader; + BEGIN + rd := c.text.NewReader(c.cachedRd); c.cachedRd := NIL; RETURN rd + END CachedReader; + + PROCEDURE CacheReader (c: StdCtrl; rd: TextModels.Reader); + BEGIN + c.cachedRd := rd + END CacheReader; + + + PROCEDURE CachedWriter (c: StdCtrl; attr: TextModels.Attributes): TextModels.Writer; + VAR wr: TextModels.Writer; + BEGIN + wr := c.text.NewWriter(c.cachedWr); wr.SetAttr(attr); + c.cachedRd := NIL; RETURN wr + END CachedWriter; + + PROCEDURE CacheWriter (c: StdCtrl; wr: TextModels.Writer); + BEGIN + c.cachedWr := wr + END CacheWriter; + + + (** Controller **) + + PROCEDURE (c: Controller) Internalize2- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR v: INTEGER; + BEGIN + (* c.Internalize^(rd); *) + rd.ReadVersion(minVersion, maxVersion, v) + END Internalize2; + + PROCEDURE (c: Controller) Externalize2- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + (* c.Externalize^(wr); *) + wr.WriteVersion(maxVersion) + END Externalize2; + + PROCEDURE (c: Controller) InitView2* (v: Views.View), EXTENSIBLE; + BEGIN + ASSERT((v = NIL) # (c.view = NIL), 21); + IF c.view = NIL THEN ASSERT(v IS TextViews.View, 22) END; + (* c.InitView^(v); *) + IF v # NIL THEN c.view := v(TextViews.View); c.text := c.view.ThisModel() + ELSE c.view := NIL; c.text := NIL + END + END InitView2; + + PROCEDURE (c: Controller) ThisView* (): TextViews.View, EXTENSIBLE; + BEGIN + RETURN c.view + END ThisView; + + + (** caret **) + + PROCEDURE (c: Controller) CaretPos* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (c: Controller) SetCaret* (pos: INTEGER), NEW, ABSTRACT; + (** pre: pos = none OR 0 <= pos <= c.text.Length() **) + (** post: c.carPos = pos **) + + + (** selection **) + + PROCEDURE (c: Controller) GetSelection* (OUT beg, end: INTEGER), NEW, ABSTRACT; + (** post: beg = end OR 0 <= beg <= end <= c.text.Length() **) + + PROCEDURE (c: Controller) SetSelection* (beg, end: INTEGER), NEW, ABSTRACT; + (** pre: beg = end OR 0 <= beg < end <= c.text.Length() **) + (** post: c.selBeg = beg, c.selEnd = end **) + + + (** Directory **) + + PROCEDURE (d: Directory) NewController* (opts: SET): Controller, ABSTRACT; + + PROCEDURE (d: Directory) New* (): Controller, EXTENSIBLE; + BEGIN + RETURN d.NewController({}) + END New; + + + (** miscellaneous **) + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); dir := d + END SetDir; + + PROCEDURE Install*; + BEGIN + TextViews.SetCtrlDir(dir) + END Install; + + + PROCEDURE Focus* (): Controller; + VAR v: Views.View; c: Containers.Controller; + BEGIN + v := Controllers.FocusView(); + IF (v # NIL) & (v IS TextViews.View) THEN + c := v(TextViews.View).ThisController(); + IF (c # NIL) & (c IS Controller) THEN RETURN c(Controller) + ELSE RETURN NIL + END + ELSE RETURN NIL + END + END Focus; + + + PROCEDURE SetCaret* (text: TextModels.Model; pos: INTEGER); + (** pre: text # NIL, pos = none OR 0 <= pos <= text.Length() **) + VAR cm: SetCaretMsg; + BEGIN + ASSERT(text # NIL, 20); ASSERT(none <= pos, 21); ASSERT(pos <= text.Length(), 22); + cm.pos := pos; Models.Broadcast(text, cm) + END SetCaret; + + PROCEDURE SetSelection* (text: TextModels.Model; beg, end: INTEGER); + (** pre: text # NIL, beg = end OR 0 <= beg < end <= text.Length() **) + VAR sm: SetSelectionMsg; + BEGIN + ASSERT(text # NIL, 20); + IF beg # end THEN + ASSERT(0 <= beg, 21); ASSERT(beg < end, 22); ASSERT(end <= text.Length(), 23) + END; + sm.beg := beg; sm.end := end; Models.Broadcast(text, sm) + END SetSelection; + + + (* support for cursor/selection/focus marking *) + + PROCEDURE BlinkCaret (c: StdCtrl; f: Views.Frame; tick: INTEGER); + VAR vis: BOOLEAN; + BEGIN + IF (c.carPos # none) & f.front & (tick >= c.carTick) THEN + IF c.carVisible THEN + c.MarkCaret(f, Containers.hide); c.carVisible := FALSE + ELSE + c.carVisible := TRUE; c.MarkCaret(f, Containers.show) + END; + c.carTick := tick + Dialog.caretPeriod + END + END BlinkCaret; + + PROCEDURE FlipCaret (c: StdCtrl; show: BOOLEAN); + VAR msg: CaretMsg; + BEGIN + msg.show := show; + Views.Broadcast(c.view, msg) + END FlipCaret; + + PROCEDURE CheckCaret (c: StdCtrl); + VAR text: TextModels.Model; len, pos: INTEGER; + BEGIN + IF ~(Containers.noCaret IN c.opts) THEN + IF (c.carPos = none) & ~(boundCaret & (c.selBeg # c.selEnd)) & (c.ThisFocus() = NIL) THEN + text := c.text; len := text.Length(); pos := c.carLast; + IF pos < 0 THEN pos := 0 ELSIF pos > len THEN pos := len END; + (* c.carVisible := FALSE; c.carTick := 0; (* force visible mark *) *) + SetCaret(text, pos) + END + ELSE c.carPos := none + END + END CheckCaret; + + + + PROCEDURE HiliteRect (f: Views.Frame; l, t, r, b, s: INTEGER; show: BOOLEAN); + BEGIN + IF s = Ports.fill THEN + f.MarkRect(l, t, r, b, Ports.fill, Ports.hilite, show) + ELSE + f.MarkRect(l, t, r - s, t + s, s, Ports.hilite, show); + f.MarkRect(l, t + s, l + s, b - s, s, Ports.hilite, show); + f.MarkRect(l + s, b - s, r, b, s, Ports.hilite, show); + f.MarkRect(r - s, t + s, r, b - s, s, Ports.hilite, show) + END + END HiliteRect; + + PROCEDURE MarkSelRange (c: StdCtrl; f: Views.Frame; b, e: TextViews.Location; + front, show: BOOLEAN + ); + VAR fw, ff, r, t: INTEGER; + BEGIN + IF front THEN fw := 0; ff := Ports.fill ELSE fw := f.dot; ff := fw END; + IF b.start # e.start THEN + r := f.r; t := b.y + b.asc + b.dsc; + HiliteRect(f, b.x, b.y, r + fw, t + fw, ff, show); + IF t < e.y THEN HiliteRect(f, 0, t, r + fw, e.y + fw, ff, show) END; + b.x := f.l; b.y := e.y + END; + HiliteRect(f, b.x, b.y, e.x + fw, e.y + e.asc + e.dsc + fw, ff, show) + END MarkSelRange; + + PROCEDURE MarkSelection (c: StdCtrl; f: Views.Frame; beg, end: INTEGER; show: BOOLEAN); + VAR b, e: TextViews.Location; s: Views.View; + BEGIN + IF (beg # end) & f.mark THEN + ASSERT(beg < end, 20); + s := c.Singleton(); + IF s # NIL THEN + IF beg + 1 = end THEN Containers.MarkSingleton(c, f, show) END + ELSE + c.view.GetThisLocation(f, beg, b); c.view.GetThisLocation(f, end, e); + IF (b.pos < e.pos) OR (b.pos = e.pos) & (b.x < e.x) THEN + MarkSelRange(c, f, b, e, f.front, show) + END + END + END + END MarkSelection; + + PROCEDURE FlipSelection (c: StdCtrl; beg, end: INTEGER; show: BOOLEAN); + VAR msg: SelectionMsg; + BEGIN + msg.beg := beg; msg.end := end; msg.show := show; + Views.Broadcast(c.view, msg) + END FlipSelection; + + + PROCEDURE InitMarks (c: StdCtrl); + BEGIN + c.autoBeg := MAX(INTEGER); c.autoEnd := 0; + c.carPos := none; c.carVisible := FALSE; c.carLast := none; c.carTick := 0; c.carX := -1; + c.selBeg := none; c.selEnd := none; + c.lastStep := 0 + END InitMarks; + + PROCEDURE AutoShowRange (c: StdCtrl; beg, end: INTEGER); + BEGIN + IF (beg <= c.autoBeg) & (c.autoEnd <= end) THEN + c.autoBeg := beg; c.autoEnd := end (* new range includes old range: expand *) + ELSE + c.autoBeg := -1 (* schizopheric scroll request -> don't scroll at all *) + END + END AutoShowRange; + + PROCEDURE UpdateMarks (c: StdCtrl; op: INTEGER; beg, end, delta: INTEGER); + (* ensure that marks are valid after updates *) + BEGIN + CASE op OF + TextModels.insert: + c.carLast := end; c.selBeg := end; c.selEnd := end; beg := end + | TextModels.delete: + c.carLast := beg; c.selBeg := beg; c.selEnd := beg; end := beg + | TextModels.replace: + ELSE + HALT(100) + END; + AutoShowRange(c, beg, end) + END UpdateMarks; + + + (* support for smart cut/copy/paste and attributing *) + + PROCEDURE LegalChar (ch: CHAR): BOOLEAN; + BEGIN + IF ch < 100X THEN + CASE ORD(ch) OF + ORD(viewcode), + ORD(tab), ORD(line), ORD(para), + ORD(" ") .. 7EH, 80H .. 0FFH: RETURN TRUE + ELSE RETURN FALSE + END + ELSE RETURN TRUE + END + END LegalChar; + + PROCEDURE LeftTerminator (ch: CHAR): BOOLEAN; + BEGIN + IF ch < 100X THEN + CASE ch OF + viewcode, tab, line, para, '"', "'", "(", "[", "{": RETURN TRUE + ELSE RETURN FALSE + END + ELSE RETURN TRUE + END + END LeftTerminator; + + PROCEDURE RightTerminator (ch, ch1: CHAR): BOOLEAN; + BEGIN + IF ch < 100X THEN + CASE ch OF + 0X, viewcode, tab, line, para, + "!", '"', "'", "(", ")", ",", ";", "?", "[", "]", "{", "}": RETURN TRUE + | ".", ":": + CASE ch1 OF + 0X, viewcode, tab, line, para, " ": RETURN TRUE + ELSE RETURN FALSE + END + ELSE RETURN FALSE + END + ELSE RETURN TRUE + END + END RightTerminator; + + PROCEDURE ReadLeft (rd: TextModels.Reader; pos: INTEGER; OUT ch: CHAR); + BEGIN + IF pos > 0 THEN rd.SetPos(pos - 1); rd.ReadChar(ch) + ELSE rd.SetPos(pos); ch := " " + END + END ReadLeft; + + PROCEDURE SmartRange (c: StdCtrl; VAR beg, end: INTEGER); + (* if possible and whole words are covered, + extend [beg, end) to encompass either a leading or a trailing blank *) + VAR rd: TextModels.Reader; we, be: INTEGER; ch, ch0, ch1: CHAR; rightTerm: BOOLEAN; + BEGIN +(* +disable intelligent delete/cut/move for now + rd := CachedReader(c); ReadLeft(rd, beg, ch0); rd.ReadChar(ch); + IF ((ch0 <= " ") OR LeftTerminator(ch0)) & (ch # " ") THEN + (* range covers beg of word *) + we := beg; be := beg; + WHILE (ch # 0X) & (be <= end) DO + ch1 := ch; rd.ReadChar(ch); INC(be); + IF (ch1 # " ") & ((be <= end) OR ~RightTerminator(ch1, ch)) THEN we := be END + END; + rightTerm := RightTerminator(ch1, ch); + IF (beg < we) & (we = end) & ((we < be) OR rightTerm) THEN + (* range covers end of word *) + IF (we < be) & (ch1 = " ") THEN + INC(end) (* include trailing blank *) + ELSIF (beg > 0) & rightTerm & (ch0 = " ") THEN + DEC(beg) (* include leading blank *) + END + END + END; + CacheReader(c, rd) +*) + END SmartRange; + + PROCEDURE OnlyWords (c: StdCtrl; beg, end: INTEGER): BOOLEAN; + VAR rd: TextModels.Reader; we, be: INTEGER; ch, ch0, ch1: CHAR; + rightTerm, words: BOOLEAN; + BEGIN + words := FALSE; + rd := CachedReader(c); ReadLeft(rd, beg, ch0); rd.ReadChar(ch); + IF ((ch0 <= " ") OR LeftTerminator(ch0)) & (ch # " ") THEN (* range covers beg of word *) + we := beg; be := beg; + WHILE (ch # 0X) & (be <= end) DO + ch1 := ch; rd.ReadChar(ch); INC(be); + IF (ch1 # " ") & ((be <= end) OR ~RightTerminator(ch1, ch)) THEN + we := be + END + END; + rightTerm := RightTerminator(ch1, ch); + IF (beg < we) & (we = end) & ((we < be) OR rightTerm) THEN (* range covers end of word *) + words := TRUE + END + END; + CacheReader(c, rd); + RETURN words + END OnlyWords; + + PROCEDURE GetTargetField (t: TextModels.Model; pos: INTEGER; + VAR touchL, touchM, touchR: BOOLEAN + ); + VAR rd: TextModels.Reader; ch0, ch1: CHAR; leftTerm, rightTerm: BOOLEAN; + BEGIN + rd := t.NewReader(NIL); ReadLeft(rd, pos, ch0); rd.ReadChar(ch1); + leftTerm := (ch0 <= " ") OR LeftTerminator(ch0); + rightTerm := (ch1 <= " ") OR RightTerminator(ch1, 0X); + touchL := ~leftTerm & rightTerm; + touchM := ~leftTerm & ~rightTerm; + touchR := leftTerm & ~rightTerm + END GetTargetField; + + PROCEDURE LeftExtend (t: TextModels.Model; attr: TextModels.Attributes); + VAR wr: TextModels.Writer; + BEGIN + wr := t.NewWriter(NIL); wr.SetAttr(attr); wr.SetPos(0); wr.WriteChar(" ") + END LeftExtend; + + PROCEDURE RightExtend (t: TextModels.Model; attr: TextModels.Attributes); + VAR wr: TextModels.Writer; + BEGIN + wr := t.NewWriter(NIL); wr.SetPos(t.Length()); wr.SetAttr(attr); wr.WriteChar(" ") + END RightExtend; + + PROCEDURE MergeAdjust (target, inset: TextModels.Model; pos: INTEGER; OUT start: INTEGER); + VAR rd: TextModels.Reader; a: TextModels.Attributes; ch, ch1: CHAR; + touchL, touchM, touchR: BOOLEAN; + BEGIN + start := pos; +(* +disable intelligent paste for now + GetTargetField(target, pos, touchL, touchM, touchR); + IF touchL THEN + rd := inset.NewReader(NIL); rd.SetPos(0); + rd.ReadChar(ch); a := rd.attr; rd.ReadChar(ch1); + IF (ch > " ") & ~RightTerminator(ch, ch1) THEN LeftExtend(inset, a); INC(start) END + END; + IF touchR & (inset.Length() > 0) THEN + rd := inset.NewReader(rd); rd.SetPos(inset.Length() - 1); rd.ReadChar(ch); + IF (ch > " ") & ~LeftTerminator(ch) THEN RightExtend(inset, rd.attr) END + END +*) + END MergeAdjust; + + + PROCEDURE InsertionAttr (c: StdCtrl): TextModels.Attributes; + VAR rd: TextModels.Reader; r: TextRulers.Ruler; a: TextModels.Attributes; ch: CHAR; + BEGIN + a := c.insAttr; + IF a = NIL THEN + rd := CachedReader(c); a := NIL; + IF c.carPos # none THEN + ReadLeft(rd, c.carPos, ch); a := rd.attr; + IF ((ch <= " ") OR (ch = TextModels.nbspace)) & (c.carPos < c.text.Length()) THEN + rd.ReadChar(ch); + IF ch > " " THEN a := rd.attr END + END + ELSIF boundCaret & (c.selBeg # c.selEnd) THEN + rd.SetPos(c.selBeg); rd.ReadChar(ch); a := rd.attr; + c.insAttr := a + END; + IF a = NIL THEN c.view.PollDefaults(r, a) END; + CacheReader(c, rd) + END; + RETURN a + END InsertionAttr; + + + PROCEDURE GetTargetRange (c: StdCtrl; OUT beg, end: INTEGER); + BEGIN + IF boundCaret & (c.selBeg # c.selEnd) THEN + beg := c.selBeg; end := c.selEnd + ELSE + beg := c.carPos; end := beg + END + END GetTargetRange; + + + PROCEDURE DoEdit (name: Stores.OpName; + c: StdCtrl; beg, end: INTEGER; + attr: TextModels.Attributes; ch: CHAR; view: Views.View; w, h: INTEGER; + buf: TextModels.Model; bufbeg, bufend: INTEGER; (* buf # NIL & bufend < 0: bufend = buf.Length() *) + pos: INTEGER + ); + VAR script: Stores.Operation; wr: TextModels.Writer; cluster: BOOLEAN; + BEGIN + IF (beg < end) (* something to delete *) + OR (attr # NIL) (* something new to write *) + OR (buf # NIL) (* something new to insert *) + THEN + cluster := (beg < end) OR (attr = NIL) OR (view # NIL); + (* don't script when typing a single character -> TextModels will bunch if possible *) + (* ~cluster => name is reverted to #System.Inserting by TextModels *) + IF cluster THEN Models.BeginScript(c.text, name, script) END; + IF beg < end THEN + c.text.Delete(beg, end); + IF pos > beg THEN DEC(pos, end - beg) END + END; + IF attr # NIL THEN + ASSERT(buf = NIL, 20); + wr := CachedWriter(c, attr); wr.SetPos(pos); + IF view # NIL THEN wr.WriteView(view, w, h) ELSE wr.WriteChar(ch) END; + CacheWriter(c, wr) + ELSIF buf # NIL THEN + IF bufend < 0 THEN bufend := buf.Length() END; + c.text.Insert(pos, buf, bufbeg, bufend) + END; + IF cluster THEN Models.EndScript(c.text, script) END; + CheckCaret(c) + END + END DoEdit; + + + (* editing *) + + PROCEDURE ThisPos (v: TextViews.View; f: Views.Frame; x, y: INTEGER): INTEGER; + VAR loc: TextViews.Location; pos: INTEGER; + BEGIN + pos := v.ThisPos(f, x, y); v.GetThisLocation(f, pos, loc); + IF (loc.view # NIL) & (x > (loc.l + loc.r) DIV 2) THEN INC(pos) END; + RETURN pos + END ThisPos; + + PROCEDURE ShowPos (c: StdCtrl; beg, end: INTEGER); + BEGIN + IF ~(noAutoScroll IN c.opts) THEN + c.view.ShowRange(beg, end, TextViews.focusOnly) + END + END ShowPos; + + + PROCEDURE Indentation (c: StdCtrl; pos: INTEGER): TextModels.Model; + (* pre: c.carPos # none *) + VAR st: TextSetters.Setter; buf: TextModels.Model; rd: TextModels.Reader; + wr: TextModels.Writer; ch: CHAR; spos: INTEGER; + BEGIN + buf := NIL; + rd := CachedReader(c); + st := c.view.ThisSetter(); spos := st.ThisSequence(pos); rd.SetPos(spos); rd.ReadChar(ch); + IF (ch = tab) & (spos < pos) THEN + buf := TextModels.CloneOf(c.text); wr := buf.NewWriter(NIL); wr.SetPos(buf.Length()); + wr.SetAttr(InsertionAttr(c)); + wr.WriteChar(line); + REPEAT wr.WriteChar(tab); rd.ReadChar(ch) UNTIL (ch # tab) OR (rd.Pos() > pos) + END; + CacheReader(c, rd); + RETURN buf + END Indentation; + + PROCEDURE InsertChar (c: StdCtrl; ch: CHAR); + VAR buf: TextModels.Model; attr: TextModels.Attributes; + beg, end: INTEGER; legal: BOOLEAN; name: Stores.OpName; + BEGIN + attr := NIL; buf := NIL; + IF ch < 100X THEN legal := LegalChar(ch) ELSE legal := TRUE END; (* should check Unicode *) + IF (ch = ldel) OR (ch = rdel) THEN name := deletingKey ELSE name := replacingKey END; + IF boundCaret & (c.selBeg # c.selEnd) & (legal OR (ch = ldel) OR (ch = rdel) OR (ch = enter)) THEN + beg := c.selBeg; end := c.selEnd; + IF (ch = ldel) OR (ch = rdel) THEN SmartRange(c, beg, end); ch := 0X END + ELSE + beg := c.carPos; end := beg + END; + IF (c.carPos # none) OR boundCaret & (c.selBeg # c.selEnd) THEN + IF (ch = line) OR (ch = enter) THEN + IF noAutoIndent IN c.opts THEN buf := NIL ELSE buf := Indentation(c, beg) END; + IF buf = NIL THEN ch := line; legal := TRUE ELSE ch := 0X; legal := FALSE END + END; + IF legal THEN + attr := InsertionAttr(c) + ELSIF (ch = ldel) & (c.carPos > 0) THEN + beg := c.carPos - 1; end := c.carPos + ELSIF (ch = rdel) & (c.carPos < c.text.Length()) THEN + beg := c.carPos; end := c.carPos + 1 + END + END; + DoEdit(name, c, beg, end, attr, ch, NIL, 0, 0, buf, 0, -1, beg) + END InsertChar; + + PROCEDURE InsertText (c: StdCtrl; beg, end: INTEGER; text: TextModels.Model; OUT start: INTEGER); + VAR buf: TextModels.Model; + BEGIN + buf := TextModels.CloneOf(text); buf.InsertCopy(0, text, 0, text.Length()); + IF beg = end THEN MergeAdjust(c.text, buf, beg, start) ELSE start := beg END; + DoEdit(insertingKey, c, beg, end, NIL, 0X, NIL, 0, 0, buf, 0, -1, beg) + END InsertText; + + PROCEDURE InsertView (c: StdCtrl; beg, end: INTEGER; v: Views.View; w, h: INTEGER); + BEGIN + DoEdit(insertingKey, c, beg, end, InsertionAttr(c), 0X, v, w, h, NIL, 0, 0, beg) + END InsertView; + + + PROCEDURE InSubFrame (f, f1: Views.Frame; x, y: INTEGER): BOOLEAN; + BEGIN + INC(x, f.gx - f1.gx); INC(y, f.gy - f1.gy); + RETURN (f1.l <= x) & (x < f1.r) & (f1.t <= y) & (y < f1.b) + END InSubFrame; + + 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; + + + (* filtered tracking *) + + PROCEDURE IsFilter (v: Views.View; c: StdCtrl; f: Views.Frame; x, y: INTEGER): BOOLEAN; + VAR pref: FilterPref; + BEGIN + pref.controller := c; pref.frame := f; pref.x := x; pref.y := y; + pref.filter := FALSE; + Views.HandlePropMsg(v, pref); + RETURN pref.filter + END IsFilter; + + PROCEDURE FindFilter (c: StdCtrl; f: Views.Frame; x, y: INTEGER; OUT filter: Views.View); + CONST catchRange = 1000; + VAR rd: TextModels.Reader; pos, beg, end: INTEGER; isF: BOOLEAN; + BEGIN + c.view.GetRange(f, beg, end); DEC(beg, catchRange); + pos := c.view.ThisPos(f, x, y); + IF pos < c.text.Length() THEN INC(pos) END; (* let filter handle itself *) + rd := CachedReader(c); rd.SetPos(pos); + REPEAT + rd.ReadPrevView(filter); + isF := (filter # NIL) & IsFilter(filter, c, f, x, y); + UNTIL isF OR rd.eot OR (rd.Pos() < beg); + IF ~isF THEN filter := NIL END; + CacheReader(c, rd) + END FindFilter; + + PROCEDURE FilteredPollCursor (c: StdCtrl; f: Views.Frame; + VAR msg: Controllers.PollCursorMsg; VAR done: BOOLEAN + ); + VAR filter, focus: Views.View; x, y: INTEGER; modifiers: SET; isDown: BOOLEAN; fmsg: FilterPollCursorMsg; + BEGIN + FindFilter(c, f, msg.x, msg.y, filter); + IF filter # NIL THEN + (* f.Input(x, y, modifiers, isDown); *) + fmsg.x := msg.x; fmsg.y := msg.y; fmsg.cursor := msg.cursor; + fmsg.controller := c; fmsg.done := FALSE; + (*Views.ForwardCtrlMsg(f, fmsg) - does not work f.view # filter !!*) + focus := NIL; + filter.HandleCtrlMsg(f, fmsg, focus); + IF fmsg.done THEN msg.cursor := fmsg.cursor END; + done := fmsg.done + END + END FilteredPollCursor; + + PROCEDURE FilteredTrack (c: StdCtrl; f: Views.Frame; + VAR msg: Controllers.TrackMsg; VAR done: BOOLEAN + ); + VAR filter, focus: Views.View; fmsg: FilterTrackMsg; + BEGIN + FindFilter(c, f, msg.x, msg.y, filter); + IF filter # NIL THEN + fmsg.x := msg.x; fmsg.y := msg.y; fmsg.modifiers := msg.modifiers; + fmsg.controller := c; fmsg.done := FALSE; + (*Views.ForwardCtrlMsg(f, fmsg) - does not work f.view # filter !!*) + focus := NIL; filter.HandleCtrlMsg(f, fmsg, focus); + done := fmsg.done + END + END FilteredTrack; + + + (* StdCtrl *) + + PROCEDURE (c: StdCtrl) Internalize2 (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + c.Internalize2^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + InitMarks(c) + END Internalize2; + + PROCEDURE (c: StdCtrl) Externalize2 (VAR wr: Stores.Writer); + BEGIN + c.Externalize2^(wr); + wr.WriteVersion(maxStdVersion) + END Externalize2; + + PROCEDURE (c: StdCtrl) CopyFrom (source: Stores.Store); + BEGIN + c.CopyFrom^(source); InitMarks(c) + END CopyFrom; + + PROCEDURE (c: StdCtrl) Neutralize2; + BEGIN + (* c.Neutralize^; *) + c.SetCaret(none) + END Neutralize2; + + PROCEDURE (c: StdCtrl) GetContextType (OUT type: Stores.TypeName); + BEGIN + type := "TextViews.View" + END GetContextType; + + PROCEDURE (c: StdCtrl) GetValidOps (OUT valid: SET); + BEGIN + valid := {}; + IF (c.carPos # none) OR (boundCaret & (c.selBeg # c.selEnd)) THEN + valid := valid + {Controllers.pasteChar, Controllers.paste} + END; + IF c.selBeg # c.selEnd THEN + valid := valid + {Controllers.cut, Controllers.copy} + END + END GetValidOps; + + PROCEDURE (c: StdCtrl) NativeModel (m: Models.Model): BOOLEAN; + BEGIN + ASSERT(m # NIL, 20); + RETURN m IS TextModels.Model + END NativeModel; + + PROCEDURE (c: StdCtrl) NativeView (v: Views.View): BOOLEAN; + BEGIN + ASSERT(v # NIL, 20); + RETURN v IS TextViews.View + END NativeView; + + PROCEDURE (c: StdCtrl) NativeCursorAt (f: Views.Frame; x, y: INTEGER): INTEGER; + BEGIN + RETURN Ports.textCursor + END NativeCursorAt; + + PROCEDURE (c: StdCtrl) PollNativeProp (selection: BOOLEAN; + VAR p: Properties.Property; VAR truncated: BOOLEAN + ); + VAR beg, end: INTEGER; + BEGIN + IF selection & (c.selBeg = c.selEnd) THEN + p := InsertionAttr(c).Prop(); truncated := FALSE + ELSE + IF selection THEN beg := c.selBeg; end := c.selEnd + ELSE beg := 0; end := c.text.Length() + END; +(* + truncated := (end - beg > lenCutoff); + IF truncated THEN end := beg + lenCutoff END; +*) + p := c.text.Prop(beg, end) + END + END PollNativeProp; + + PROCEDURE (c: StdCtrl) SetNativeProp (selection: BOOLEAN; old, p: Properties.Property); + VAR t: TextModels.Model; beg, end: INTEGER; + BEGIN + t := c.text; + IF selection THEN beg := c.selBeg; end := c.selEnd ELSE beg := 0; end := t.Length() END; + IF beg < end THEN + t.Modify(beg, end, old, p); + IF selection THEN c.SetSelection(beg, end) END + ELSIF selection THEN + c.insAttr := TextModels.ModifiedAttr(InsertionAttr(c), p) + END + END SetNativeProp; + + PROCEDURE (c: StdCtrl) MakeViewVisible (v: Views.View); + VAR pos: INTEGER; + BEGIN + ASSERT(v # NIL, 20); + ASSERT(v.context # NIL, 21); + ASSERT(v.context.ThisModel() = c.text, 22); + pos := v.context(TextModels.Context).Pos(); + ShowPos(c, pos, pos + 1) + END MakeViewVisible; + + PROCEDURE (c: StdCtrl) GetFirstView (selection: BOOLEAN; OUT v: Views.View); + VAR rd: TextModels.Reader; beg, end: INTEGER; + BEGIN + IF selection THEN beg := c.selBeg; end := c.selEnd + ELSE beg := 0; end := c.text.Length() + END; + IF beg < end THEN + rd := CachedReader(c); rd.SetPos(beg); rd.ReadView(v); + IF rd.Pos() > end THEN v := NIL END; + CacheReader(c, rd) + ELSE v := NIL + END + END GetFirstView; + + PROCEDURE (c: StdCtrl) GetNextView (selection: BOOLEAN; VAR v: Views.View); + VAR con: Models.Context; rd: TextModels.Reader; beg, end, pos: INTEGER; + BEGIN + ASSERT(v # NIL, 20); con := v.context; + ASSERT(con # NIL, 21); ASSERT(con.ThisModel() = c.text, 22); + IF selection THEN beg := c.selBeg; end := c.selEnd + ELSE beg := 0; end := c.text.Length() + END; + pos := con(TextModels.Context).Pos(); + IF (beg <= pos) & (pos < end) THEN + rd := CachedReader(c); rd.SetPos(pos + 1); rd.ReadView(v); + IF rd.Pos() > end THEN v := NIL END; + CacheReader(c, rd) + ELSE v := NIL + END + END GetNextView; + + PROCEDURE (c: StdCtrl) GetPrevView (selection: BOOLEAN; VAR v: Views.View); + VAR con: Models.Context; rd: TextModels.Reader; beg, end, pos: INTEGER; + BEGIN + ASSERT(v # NIL, 20); con := v.context; + ASSERT(con # NIL, 21); ASSERT(con.ThisModel() = c.text, 22); + IF selection THEN beg := c.selBeg; end := c.selEnd + ELSE beg := 0; end := c.text.Length() + END; + pos := con(TextModels.Context).Pos(); + IF (beg < pos) & (pos <= end) THEN + rd := CachedReader(c); rd.SetPos(pos); rd.ReadPrevView(v); + IF rd.Pos() < beg THEN v := NIL END; + CacheReader(c, rd) + ELSE v := NIL + END + END GetPrevView; + + PROCEDURE (c: StdCtrl) GetSelectionBounds (f: Views.Frame; OUT x, y, w, h: INTEGER); + VAR b, e: TextViews.Location; + BEGIN + c.GetSelectionBounds^(f, x, y, w, h); + IF w = Views.undefined THEN + c.view.GetThisLocation(f, c.selBeg, b); + c.view.GetThisLocation(f, c.selEnd, e); + IF b.start = e.start THEN x := b.x; w := e.x - b.x; + ELSE x := f.l; w := f.r - f.l; + END; + y := b.y; h := e.y + e.asc + e.dsc - b.y + END + END GetSelectionBounds; + + PROCEDURE (c: StdCtrl) MarkPickTarget (source, f: Views.Frame; + sx, sy, x, y: INTEGER; show: BOOLEAN + ); + VAR b, e: TextViews.Location; pos: INTEGER; + BEGIN + pos := c.view.ThisPos(f, x, y); + IF pos < c.text.Length() THEN + c.view.GetThisLocation(f, pos, b); + c.view.GetThisLocation(f, pos + 1, e); + IF (b.pos < e.pos) OR (b.pos = e.pos) & (b.x < e.x) THEN + MarkSelRange(c, f, b, e, TRUE, show) + END + END + END MarkPickTarget; + + PROCEDURE (c: StdCtrl) MarkDropTarget (source, f: Views.Frame; + sx, sy, dx, dy, w, h, rx, ry: INTEGER; type: Stores.TypeName; isSingle, show: BOOLEAN + ); + VAR loc: TextViews.Location; pos: INTEGER; + BEGIN + pos := c.view.ThisPos(f, dx, dy); + IF (source # NIL) & ((source.view = f.view) OR (source.view.ThisModel() = f.view.ThisModel())) + & (c.selBeg < pos) & (pos < c.selEnd) THEN + pos := c.selBeg + END; + c.view.GetThisLocation(f, pos, loc); + f.MarkRect(loc.x, loc.y, loc.x + f.unit, loc.y + loc.asc + loc.dsc, Ports.fill, Ports.invert, show); + IF (isSingle OR ~Services.Extends(type, "TextViews.View")) & (w > 0) & (h > 0) THEN + DEC(dx, rx); DEC(dy, ry); + f.MarkRect(dx, dy, dx + w, dy + h, 0, Ports.dim25, show) + END + END MarkDropTarget; + + + PROCEDURE GetThisLine (c: StdCtrl; pos: INTEGER; OUT beg, end: INTEGER); + VAR st: TextSetters.Setter; + BEGIN + st := c.view.ThisSetter(); + beg := st.ThisLine(pos); end := st.NextLine(beg); + IF end = beg THEN end := c.text.Length() END; + END GetThisLine; + + PROCEDURE GetThisChunk (c: StdCtrl; f: Views.Frame; + VAR s: TrackState; OUT beg, end: INTEGER; OUT mode: INTEGER + ); + VAR v: TextViews.View; b, e: TextViews.Location; + st: TextSetters.Setter; ruler: TextRulers.Ruler; ra: TextRulers.Attributes; + pos, r: INTEGER; + BEGIN + v := c.view; st := v.ThisSetter(); pos := ThisPos(v, f, s.x, s.y); + ruler := TextViews.ThisRuler(v, pos); ra := ruler.style.attr; + r := ra.right; IF ~(TextRulers.rightFixed IN ra.opts) OR (r > f.r) THEN r := f.r END; + st.GetWord(pos, beg, end); + v.GetThisLocation(f, beg, b); v.GetThisLocation(f, end, e); + IF (s.x < f.l) OR (s.x >= r) THEN (* outside of line box: whole line *) + GetThisLine(c, pos, beg, end); + mode := lines + ELSIF (s.y < b.y) OR (s.y < b.y + b.asc + b.dsc) & (s.x < b.x) + OR (s.y >= e.y) & (s.x >= e.x) OR (s.y >= e.y + e.asc + e.dsc) THEN + (* outside of word: single char *) + beg := ThisPos(v, f, s.x, s.y); v.GetThisLocation(f, beg, b); + IF (b.x > s.x) & (beg > 0) THEN DEC(beg) END; + IF beg < c.text.Length() THEN end := beg + 1 ELSE end := beg END; + mode := words + ELSE (* whole word *) + mode := words + END + END GetThisChunk; + + PROCEDURE SetSel (c: StdCtrl; beg, end: INTEGER); + (* pre: ~(Containers.noSelection IN c.opts) *) + BEGIN + IF beg >= end THEN c.SetCaret(beg) ELSE c.SetSelection(beg, end) END + END SetSel; + + PROCEDURE PrepareToTrack (c: StdCtrl; f: Views.Frame; + VAR s: TrackState; mode: INTEGER; + VAR pin0, pin1, pos: INTEGER + ); + VAR loc: TextViews.Location; beg, end: INTEGER; m: INTEGER; + BEGIN + pos := ThisPos(c.view, f, s.x, s.y); + IF mode IN {chars, words, lines} THEN + GetThisChunk(c, f, s, pin0, pin1, m) + ELSE pin0 := pos; pin1 := pos + END; + IF s.toggle & ((c.selBeg # c.selEnd) OR boundCaret & (c.carPos # none)) + & ~(Containers.noSelection IN c.opts) THEN (* modify existing selection *) + IF c.selBeg # c.selEnd THEN + beg := c.selBeg; end := c.selEnd + ELSE + beg := c.carPos; end := beg; c.selPin0 := beg; c.selPin1 := beg + END; + IF pin1 > c.selPin0 THEN + end := pin1; pin0 := beg + ELSIF pin0 < c.selPin1 THEN + beg := pin0; pin0 := end + END; + SetSel(c, beg, end); + pin1 := pin0 + ELSIF mode IN {chars, words, lines} THEN + SetSel(c, pin0, pin1); + pos := pin1 + ELSE + SetCaret(c.text, pos) + END; + c.lastStep := Services.Ticks() + END PrepareToTrack; + + PROCEDURE ScrollDelay (d: INTEGER): INTEGER; + VAR second, delay: INTEGER; + BEGIN + second := Services.resolution; + IF d < 2 * mm THEN delay := second DIV 2 + ELSIF d < 4 * mm THEN delay := second DIV 3 + ELSIF d < 6 * mm THEN delay := second DIV 5 + ELSIF d < 8 * mm THEN delay := second DIV 10 + ELSE delay := second DIV 20 + END; + RETURN delay + END ScrollDelay; + + PROCEDURE ScrollWhileTracking (c: StdCtrl; f: Views.Frame; VAR x0, y0, x, y: INTEGER); + (* currently, there are no provisions to scroll while tracking inside an embedded view *) + VAR now: LONGINT; (* normalize: BOOLEAN; *) scr: Controllers.ScrollMsg; + BEGIN + (* normalize := c.view.context.Normalize(); *) + now := Services.Ticks(); + IF x < f.l THEN x0 := x; x := f.l ELSIF x > f.r THEN x0 := x; x := f.r END; + IF (y < f.t) (* & normalize*) THEN + IF c.lastStep + ScrollDelay(f.t - y) <= now THEN + c.lastStep := now; + scr.focus := TRUE; scr.vertical := TRUE; scr.op := Controllers.decLine; + scr.done := FALSE; + Controllers.ForwardVia(Controllers.frontPath, scr) + END + ELSIF (y > f.b) (* & normalize *) THEN + IF c.lastStep + ScrollDelay(y - f.b) <= now THEN + c.lastStep := now; + scr.focus := TRUE; scr.vertical := TRUE; scr.op := Controllers.incLine; + scr.done := FALSE; + Controllers.ForwardVia(Controllers.frontPath, scr) + END + ELSE + y0 := y + END + END ScrollWhileTracking; + + PROCEDURE (c: StdCtrl) TrackMarks (f: Views.Frame; x, y: INTEGER; units, extend, add: BOOLEAN); + VAR s: TrackState; pos, beg, end, pin0, pin1, p, p1: INTEGER; + modifiers: SET; mode, m: INTEGER; isDown, noSel: BOOLEAN; + BEGIN + IF c.opts * Containers.mask # Containers.mask THEN (* track caret or selection *) + s.x := x; s.y := y; s.toggle := extend; + noSel := Containers.noSelection IN c.opts; + IF units & ~noSel THEN (* select units, i.e. words or lines *) + GetThisChunk(c, f, s, beg, end, mode) + ELSE (* set caret or selection *) + mode := none + END; + PrepareToTrack(c, f, s, mode, pin0, pin1, p); x := s.x; y := s.y; + beg := pin0; end := pin1; + IF p < pin0 THEN beg := p ELSIF p > pin1 THEN end := p END; + p := -1; + f.Input(s.x, s.y, modifiers, isDown); + WHILE isDown DO +(* + REPEAT + f.Input(s.x, s.y, modifiers, isDown); +*) + IF (s.x # x) OR (s.y # y) THEN + ScrollWhileTracking(c, f, x, y, s.x, s.y); + p1 := ThisPos(c.view, f, s.x, s.y); + IF p1 # p THEN + p := p1; + IF mode IN {words, lines} THEN + IF mode = words THEN + GetThisChunk(c, f, s, beg, end, m) + ELSE + GetThisLine(c, p, beg, end) + END; + IF p > pin0 THEN pos := end ELSE pos := beg END + ELSE pos := p + END; + beg := pin0; end := pin1; + IF noSel THEN + c.SetCaret(pos) + ELSE + IF pos < pin0 THEN beg := pos ELSIF pos > pin1 THEN end := pos END; + SetSel(c, beg, end); + IF c.selPin0 = c.selPin1 THEN + IF pos < pin0 THEN c.selPin0 := pos; c.selPin1 := pin1 + ELSIF pos > pin1 THEN c.selPin0 := pin0; c.selPin1 := pos + END + END + END + END + END; + f.Input(s.x, s.y, modifiers, isDown) + END +(* + UNTIL ~isDown +*) + END + END TrackMarks; + + PROCEDURE (c: StdCtrl) Resize (v: Views.View; l, t, r, b: INTEGER); + VAR con: Models.Context; + BEGIN + ASSERT(v # NIL, 20); con := v.context; + ASSERT(con # NIL, 21); ASSERT(con.ThisModel() = c.text, 22); + con.SetSize(r - l, b - t) + END Resize; + + PROCEDURE (c: StdCtrl) DeleteSelection; + VAR beg, end: INTEGER; + BEGIN + beg := c.selBeg; end := c.selEnd; + IF beg # end THEN + SmartRange(c, beg, end); + DoEdit(deletingKey, c, beg, end, NIL, 0X, NIL, 0, 0, NIL, 0, 0, 0) + END + END DeleteSelection; + + PROCEDURE (c: StdCtrl) MoveLocalSelection (f, dest: Views.Frame; x, y, dx, dy: INTEGER); + VAR buf: TextModels.Model; pos, beg0, end0, beg, end, start, len: INTEGER; + BEGIN + pos := dest.view(TextViews.View).ThisPos(dest, dx, dy); +(* smart move disabled for now --> use true move instead of copy + beg0 := c.selBeg; end0 := c.selEnd; beg := beg0; end := end0; + SmartRange(c, beg, end); + IF (beg < pos) & (pos < end) THEN pos := beg END; + buf := TextModels.CloneOf(c.text); buf.CopyFrom(0, c.text, beg0, end0); + IF OnlyWords(c, beg0, end0) THEN MergeAdjust(c.text, buf, pos, start) ELSE start := pos END; + len := end0 - beg0; + IF start >= end THEN DEC(start, end - beg) END; + IF pos # beg THEN + DoEdit(movingKey, c, beg, end, NIL, 0X, NIL, 0, 0, buf, pos); + SetSelection(c.text, start, start + len); + AutoShowRange(c, start, start + len) + END +*) + beg := c.selBeg; end := c.selEnd; + IF (pos < beg) OR (pos > end) THEN + len := end - beg; start := pos; + IF start >= end THEN DEC(start, len) END; + DoEdit(movingKey, c, 0, 0, NIL, 0X, NIL, 0, 0, c.text, beg, end, pos); + SetSelection(c.text, start, start + len); + AutoShowRange(c, start, start + len) + END + END MoveLocalSelection; + + PROCEDURE (c: StdCtrl) CopyLocalSelection (f, dest: Views.Frame; x, y, dx, dy: INTEGER); + VAR buf: TextModels.Model; pos, beg, end, start, len: INTEGER; + BEGIN + pos := dest.view(TextViews.View).ThisPos(dest, dx, dy); + beg := c.selBeg; end := c.selEnd; + IF (beg < pos) & (pos < end) THEN pos := beg END; + buf := TextModels.CloneOf(c.text); buf.InsertCopy(0, c.text, beg, end); + IF OnlyWords(c, beg, end) THEN MergeAdjust(c.text, buf, pos, start) ELSE start := pos END; + len := end - beg; + DoEdit(copyingKey, c, 0, 0, NIL, 0X, NIL, 0, 0, buf, 0, -1, pos); + SetSelection(c.text, start, start + len); + AutoShowRange(c, start, start + len) + END CopyLocalSelection; + + PROCEDURE (c: StdCtrl) SelectionCopy (): Containers.Model; + VAR t: TextModels.Model; + BEGIN + IF c.selBeg # c.selEnd THEN + t := TextModels.CloneOf(c.text); t.InsertCopy(0, c.text, c.selBeg, c.selEnd); + ELSE t := NIL + END; + RETURN t + END SelectionCopy; + + PROCEDURE (c: StdCtrl) NativePaste (m: Models.Model; f: Views.Frame); + VAR beg, end, start: INTEGER; + BEGIN + WITH m: TextModels.Model DO + GetTargetRange(c, beg, end); + IF beg # none THEN InsertText(c, beg, end, m, start) END + END + END NativePaste; + + PROCEDURE (c: StdCtrl) ArrowChar (f: Views.Frame; ch: CHAR; units, select: BOOLEAN); + VAR st: TextSetters.Setter; v: TextViews.View; loc: TextViews.Location; + org, len, p, pos, b, e, beg, end, d, d0, edge, x, dy: INTEGER; + change, rightEdge, rightDir: BOOLEAN; + scroll: Controllers.ScrollMsg; + BEGIN + c.insAttr := NIL; + Models.StopBunching(c.text); + v := c.view; st := v.ThisSetter(); + change := select OR (c.selBeg = c.selEnd); + IF c.selBeg # c.selEnd THEN beg := c.selBeg; end := c.selEnd + ELSE beg := c.carPos; end := beg; c.carLast := beg + END; + len := c.text.Length(); + rightDir := (ch = aR) OR (ch = pR) OR (ch = dR) OR (ch = aD) OR (ch = pD) OR (ch = dD); + rightEdge := change & (c.carLast < end) + OR rightDir & (~change OR (beg = end) & (c.carLast = end)); + IF rightEdge THEN edge := end ELSE edge := beg END; + ShowPos(c, edge, edge); + b := beg; e := end; d := edge; d0 := edge; + CASE ch OF + | aL: + IF units THEN + p := d; e := d; + WHILE (p > 0) & ((edge = d) OR (edge = e)) DO DEC(p); st.GetWord(p, edge, e) END; + ELSIF change THEN DEC(edge) + END + | pL, dL: + v.GetThisLocation(f, edge, loc); edge := loc.start + | aR: + IF units THEN + p := d; e := edge; + WHILE (p < len) & ((edge <= d) OR (edge = e)) DO INC(p); st.GetWord(p, edge, e) END + ELSIF change THEN INC(edge) + END + | pR, dR: + v.GetThisLocation(f, edge, loc); p := st.NextLine(loc.start); + IF p = loc.start THEN p := len ELSE DEC(p) END; + IF p > edge THEN edge := p END + | aU: + IF units THEN + p := st.ThisSequence(edge); + IF p < edge THEN edge := p ELSE edge := st.PreviousSequence(edge) END + ELSE + v.PollOrigin(org, dy); v.GetThisLocation(f, edge, loc); + IF c.lastX >= 0 THEN x := c.lastX ELSE x := loc.x END; + c.carX := x; + IF loc.start > 0 THEN + edge := v.ThisPos(f, x, loc.y - 1); + IF (edge >= loc.start) & (org > 0) THEN + v.SetOrigin(org - 1, 0); + v.GetThisLocation(f, edge, loc); + edge := v.ThisPos(f, x, loc.y - 1) + END + END + END + | pU: + v.PollOrigin(org, dy); + IF edge > org THEN edge := org + ELSIF org > 0 THEN + scroll.focus := TRUE; scroll.vertical := TRUE; scroll.op := Controllers.decPage; + scroll.done := FALSE; + Views.ForwardCtrlMsg(f, scroll); + v.PollOrigin(edge, dy) + END + | dU: + edge := 0 + | aD: + IF units THEN + p := st.NextSequence(st.ThisSequence(edge)); + IF p > edge THEN edge := p ELSE edge := st.NextSequence(p) END + ELSE + v.GetThisLocation(f, edge, loc); + IF c.lastX >= 0 THEN x := c.lastX ELSE x := loc.x END; + c.carX := x; + edge := v.ThisPos(f, x, loc.y + loc.asc + loc.dsc + 1) + END + | pD: + v.GetRange(f, b, e); + IF e < len THEN + scroll.focus := TRUE; scroll.vertical := TRUE; scroll.op := Controllers.incPage; + scroll.done := FALSE; + Views.ForwardCtrlMsg(f, scroll); + v.GetRange(f, edge, e) + ELSE edge := len + END + | dD: + edge := len + END; + IF rightEdge THEN end := edge ELSE beg := edge END; + IF ~select THEN + IF rightDir THEN beg := edge ELSE end := edge END + END; + IF beg < 0 THEN beg := 0 ELSIF beg > len THEN beg := len END; + IF end < beg THEN end := beg ELSIF end > len THEN end := len END; + IF beg = end THEN + ShowPos(c, beg, end) + ELSE + IF rightEdge THEN ShowPos(c, end - 1, end) ELSE ShowPos(c, beg, beg + 1) END + END; + SetSel(c, beg, end) + END ArrowChar; + + PROCEDURE (c: StdCtrl) ControlChar (f: Views.Frame; ch: CHAR); + BEGIN + InsertChar(c, ch) + END ControlChar; + + PROCEDURE (c: StdCtrl) PasteChar (ch: CHAR); + BEGIN + InsertChar(c, ch) + END PasteChar; + + PROCEDURE (c: StdCtrl) PasteView (f: Views.Frame; v: Views.View; w, h: INTEGER); + VAR t: TextModels.Model; pos, start, beg, end, len: INTEGER; + BEGIN + GetTargetRange(c, beg, end); + IF beg # none THEN InsertView(c, beg, end, v, w, h) END + END PasteView; + + PROCEDURE (c: StdCtrl) Drop (src, f: Views.Frame; sx, sy, x, y, w, h, rx, ry: INTEGER; + v: Views.View; isSingle: BOOLEAN + ); + VAR t: TextModels.Model; pos, start, beg, end, len: INTEGER; + BEGIN + pos := ThisPos(c.view, f, x, y); + WITH v: TextViews.View DO t := v.ThisModel() ELSE t := NIL END; + IF (t # NIL) & ~isSingle THEN + InsertText(c, pos, pos, t, start); len := t.Length() + ELSE + InsertView(c, pos, pos, v, w, h); start := pos; len := 1 + END; + SetSelection(c.text, start, start + len); + AutoShowRange(c, start, start + len) + END Drop; + + PROCEDURE (c: StdCtrl) PickNativeProp (f: Views.Frame; x, y: INTEGER; VAR p: Properties.Property); + VAR rd: TextModels.Reader; + BEGIN + rd := CachedReader(c); rd.SetPos(ThisPos(c.view, f, x, y)); rd.Read; + IF ~rd.eot THEN p := rd.attr.Prop() ELSE p := NIL END; + CacheReader(c, rd) + END PickNativeProp; + + PROCEDURE (c: StdCtrl) HandleModelMsg (VAR msg: Models.Message); + VAR done: BOOLEAN; + BEGIN + c.HandleModelMsg^(msg); + IF msg.model = c.text THEN + WITH msg: Models.UpdateMsg DO + WITH msg: TextModels.UpdateMsg DO + CASE msg.op OF + TextModels.insert, TextModels.delete, TextModels.replace: + UpdateMarks(c, msg.op, msg.beg, msg.end, msg.delta) + ELSE (* unknown text op happened *) + c.view.Neutralize + END + ELSE (* unknown text update happened *) + c.view.Neutralize + END + | msg: ModelMessage DO + WITH msg: SetCaretMsg DO + c.SetCaret(msg.pos) + | msg: SetSelectionMsg DO + c.SetSelection(msg.beg, msg.end) + ELSE + END + ELSE + END + END + END HandleModelMsg; + + PROCEDURE (c: StdCtrl) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message); + BEGIN + c.HandleViewMsg^(f, msg); + IF msg.view = c.view THEN + WITH msg: ViewMessage DO + WITH msg: CaretMsg DO + c.MarkCaret(f, msg.show) + | msg: SelectionMsg DO + MarkSelection(c, f, msg.beg, msg.end, msg.show) + END + ELSE + END + END + END HandleViewMsg; + + PROCEDURE (c: StdCtrl) HandleCtrlMsg (f: Views.Frame; + VAR msg: Controllers.Message; VAR focus: Views.View + ); + VAR g: Views.Frame; beg, end: INTEGER; done: BOOLEAN; + BEGIN + IF (msg IS Controllers.MarkMsg) OR (msg IS Controllers.TickMsg) THEN + beg := c.autoBeg; end := c.autoEnd; + c.autoBeg := MAX(INTEGER); c.autoEnd := 0 + END; + WITH msg: Controllers.TickMsg DO + IF ~(noAutoScroll IN c.opts) + & (0 <= beg) & (beg <= end) & (end <= c.text.Length()) + & c.view.context.Normalize() + THEN + c.view.ShowRange(beg, end, TextViews.focusOnly) + END; + IF focus = NIL THEN + CheckCaret(c); BlinkCaret(c, f, msg.tick); + IF (c.selBeg # c.aliasSelBeg) OR (c.selEnd # c.aliasSelEnd) THEN + (* lazy update of text-synchronous alias marks *) + c.aliasSelBeg := c.selBeg; c.aliasSelEnd := c.selEnd; + SetSelection(c.text, c.selBeg, c.selEnd) + END + END + | msg: Controllers.MarkMsg DO + c.carX := -1; + IF msg.show THEN c.carVisible := TRUE; c.carTick := 0 END + | msg: Controllers.TrackMsg DO + c.insAttr := NIL; c.carX := -1; Models.StopBunching(c.text) + | msg: Controllers.EditMsg DO + c.lastX := c.carX; c.carX := -1; + IF focus = NIL THEN CheckCaret(c) END + | msg: Controllers.ReplaceViewMsg DO + c.carX := -1 + | msg: Controllers.TransferMessage DO + c.carX := -1 + | msg: Properties.EmitMsg DO + c.carX := -1 + ELSE + END; + done := FALSE; + WITH msg: Controllers.CursorMessage DO + IF TRUE (* Containers.noCaret IN c.opts *) THEN (* mask or browser mode *) + g := Views.FrameAt(f, msg.x, msg.y); + IF (g = NIL) OR IsFilter(g.view, c, f, msg.x, msg.y) THEN + WITH msg: Controllers.PollCursorMsg DO + FilteredPollCursor(c, f, msg, done) + | msg: Controllers.TrackMsg DO + FilteredTrack(c, f, msg, done) + ELSE + END + END + END + ELSE + END; + IF ~done THEN c.HandleCtrlMsg^(f, msg, focus) END + END HandleCtrlMsg; + + + (* caret *) + + PROCEDURE (c: StdCtrl) HasCaret (): BOOLEAN; + BEGIN + RETURN c.carPos # none + END HasCaret; + + PROCEDURE (c: StdCtrl) MarkCaret (f: Views.Frame; show: BOOLEAN); + CONST carW = 1; carMinH = 7; (* in frame dots *) + VAR loc: TextViews.Location; pos, beg, end, u, x, y, w, h: INTEGER; fm: INTEGER; + BEGIN + pos := c.carPos; + IF (pos # none) & f.mark & (f.front & c.carVisible OR ~f.front) THEN + c.view.GetRange(f, beg, end); + IF (beg <= pos) & (pos <= end) THEN + u := f.dot; + c.view.GetThisLocation(f, pos, loc); + IF f.front THEN fm := Ports.invert ELSE fm := Ports.dim50 END; + x := loc.x; y := loc.y; h := loc.asc + loc.dsc; + IF Dialog.thickCaret THEN w := 2 * carW * u ELSE w := carW * u END; + IF x >= f.r - w THEN DEC(x, w) END; + IF h < carMinH * u THEN h := carMinH * u END; (* special caret in lines of (almost) zero height *) + f.MarkRect(x, y, x + w, y + h, Ports.fill, fm, show) + END + END + END MarkCaret; + + PROCEDURE (c: StdCtrl) CaretPos (): INTEGER; + BEGIN + RETURN c.carPos + END CaretPos; + + PROCEDURE (c: StdCtrl) SetCaret (pos: INTEGER); + BEGIN + ASSERT(none <= pos, 20); ASSERT(pos <= c.text.Length(), 21); + c.insAttr := NIL; + IF pos # c.carPos THEN + IF (pos # none) & (c.carPos = none) THEN + IF boundCaret THEN c.SetSelection(none, none) END; + c.SetFocus(NIL) + END; + + IF Containers.noCaret IN c.opts THEN pos := none END; + IF c.carPos # none THEN + c.carLast := c.carPos; FlipCaret(c, Containers.hide) + END; + c.carPos := pos; + IF pos # none THEN + c.carVisible := TRUE; c.carTick := Services.Ticks() + Dialog.caretPeriod; FlipCaret(c, Containers.show) + END + END + END SetCaret; + + + (* selection *) + + PROCEDURE (c: StdCtrl) HasSelection (): BOOLEAN; + BEGIN + RETURN c.selBeg # c.selEnd + END HasSelection; + + PROCEDURE (c: StdCtrl) Selectable (): BOOLEAN; + BEGIN + RETURN c.text.Length() > 0 + END Selectable; + + PROCEDURE (c: StdCtrl) SetSingleton (s: Views.View); + VAR s0: Views.View; + BEGIN + s0 := c.Singleton(); + c.SetSingleton^(s); + s := c.Singleton(); + IF s # s0 THEN + c.insAttr := NIL; + IF s # NIL THEN + c.selBeg := s.context(TextModels.Context).Pos(); c.selEnd := c.selBeg + 1; + c.selPin0 := c.selBeg; c.selPin1 := c.selEnd + ELSE c.selBeg := none; c.selEnd := none + END + END + END SetSingleton; + + PROCEDURE (c: StdCtrl) SelectAll (select: BOOLEAN); + (** extended by subclass to include intrinsic selections **) + BEGIN + IF select THEN c.SetSelection(0, c.text.Length()) ELSE c.SetSelection(none, none) END + END SelectAll; + + PROCEDURE (c: StdCtrl) InSelection (f: Views.Frame; x, y: INTEGER): BOOLEAN; + (* pre: c.selBeg # c.selEnd *) + (* post: (x, y) in c.selection *) + VAR b, e: TextViews.Location; y0, y1, y2, y3: INTEGER; + BEGIN + c.view.GetThisLocation(f, c.selBeg, b); y0 := b.y; y1 := y0 + b.asc + b.dsc; + c.view.GetThisLocation(f, c.selEnd, e); y2 := e.y; y3 := y2 + e.asc + e.dsc; + RETURN ((y >= y0) & (x >= b.x) OR (y >= y1)) & ((y < y2) OR (y < y3) & (x < e.x)) + END InSelection; + + PROCEDURE (c: StdCtrl) MarkSelection (f: Views.Frame; show: BOOLEAN); + BEGIN + MarkSelection(c, f, c.selBeg, c.selEnd, show) + END MarkSelection; + + PROCEDURE (c: StdCtrl) GetSelection (OUT beg, end: INTEGER); + BEGIN + beg := c.selBeg; end := c.selEnd + END GetSelection; + + PROCEDURE (c: StdCtrl) SetSelection (beg, end: INTEGER); + VAR t: TextModels.Model; rd: TextModels.Reader; + beg0, end0, p: INTEGER; singleton: BOOLEAN; + BEGIN + t := c.text; ASSERT(t # NIL, 20); + IF Containers.noSelection IN c.opts THEN end := beg + ELSIF beg # end THEN + ASSERT(0 <= beg, 21); ASSERT(beg < end, 22); ASSERT(end <= t.Length(), 23) + END; + beg0 := c.selBeg; end0 := c.selEnd; + c.insAttr := NIL; + IF (beg # beg0) OR (end # end0) THEN + IF (beg # end) & (c.selBeg = c.selEnd) THEN + IF boundCaret THEN + IF c.carPos = end THEN p := c.carPos ELSE p := beg END; + c.SetCaret(none); c.carLast := p + END; + c.SetFocus(NIL); + c.selPin0 := beg; c.selPin1 := end + ELSIF boundCaret & (beg = end) THEN + c.selPin1 := c.selPin0 (* clear selection anchors *) + END; + IF beg + 1 = end THEN + rd := CachedReader(c); + rd.SetPos(beg); rd.Read; singleton := rd.view # NIL; + CacheReader(c, rd) + ELSE singleton := FALSE + END; + IF singleton THEN (* native or singleton -> singleton *) + IF rd.view # c.Singleton() THEN c.SetSingleton(rd.view) END + ELSIF c.Singleton() # NIL THEN (* singleton -> native *) + c.SetSingleton(NIL); + c.selBeg := beg; c.selEnd := end; + FlipSelection(c, beg, end, Containers.show) + ELSE (* native -> native *) + c.selBeg := beg; c.selEnd := end; + IF (beg0 <= beg) & (end <= end0) THEN (* reduce *) + p := end0; end0 := beg; beg := end; end := p + ELSIF (beg <= beg0) & (end0 <= end) THEN (* extend *) + p := end; end := beg0; beg0 := end0; end0 := p + ELSIF (beg <= beg0) & (beg0 <= end) THEN (* shift left *) + p := end; end := beg0; beg0 := p + ELSIF (end >= end0) & (beg <= end0) THEN (* shift right *) + p := end0; end0 := beg; beg := p + END; + IF beg0 < end0 THEN FlipSelection(c, beg0, end0, Containers.show) END; + IF beg < end THEN FlipSelection(c, beg, end, Containers.show) END + END + END + END SetSelection; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) NewController (opts: SET): Controller; + VAR c: StdCtrl; + BEGIN + NEW(c); c.SetOpts(opts); InitMarks(c); RETURN c + END NewController; + + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + NEW(d); dir := d; stdDir := d + END Init; + +BEGIN + Init +END TextControllers. diff --git a/Trurl-based/Text/Mod/Mappers.odc b/Trurl-based/Text/Mod/Mappers.odc new file mode 100644 index 0000000..42217d6 Binary files /dev/null and b/Trurl-based/Text/Mod/Mappers.odc differ diff --git a/Trurl-based/Text/Mod/Mappers.txt b/Trurl-based/Text/Mod/Mappers.txt new file mode 100644 index 0000000..f0fc9b7 --- /dev/null +++ b/Trurl-based/Text/Mod/Mappers.txt @@ -0,0 +1,596 @@ +MODULE TextMappers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Mappers.odc *) + (* DO NOT EDIT *) + + IMPORT Strings, Views, Dialog, TextModels; + + CONST + (** Scanner.opts **) + returnCtrlChars* = 1; + returnQualIdents* = 2; returnViews* = 3; + interpretBools* = 4; interpretSets* = 5; + maskViews* = 6; + + (** Scanner.type **) + char* = 1; string* = 3; int* = 4; real* = 5; + bool* = 6; (** iff interpretBools IN opts **) + set* = 7; (** iff interpretSets IN opts **) + view* = 8; (** iff returnViews IN opts **) + tab* = 9; line* = 10; para* = 11; (** iff returnCtrlChars IN opts **) + lint* = 16; + eot* = 30; + invalid* = 31; (** last Scan hit lexically invalid sequence **) + + (** Formatter.WriteIntForm base **) + charCode* = Strings.charCode; decimal* = Strings.decimal; hexadecimal* = Strings.hexadecimal; + + (** Formatter.WriteIntForm showBase **) + hideBase* = Strings.hideBase; showBase* = Strings.showBase; + + VIEW = TextModels.viewcode; + TAB = TextModels.tab; LINE = TextModels.line; PARA = TextModels.para; + + acceptUnderscores = TRUE; + + TYPE + String* = ARRAY 256 OF CHAR; + + Scanner* = RECORD + opts-: SET; + rider-: TextModels.Reader; (** prefetch state for single character look-ahead **) + + type*: INTEGER; + start*, lines*, paras*: INTEGER; (** update by Skip **) + + char*: CHAR; (** valid iff type = char **) + int*: INTEGER; (** valid iff type = int **) + base*: INTEGER; (** valid iff type IN {int, lint} **) + lint*: LONGINT; (** valid iff type IN {int, lint} **) + real*: REAL; (** valid iff type = real **) + bool*: BOOLEAN; (** valid iff type = bool **) + set*: SET; (** valid iff type = set **) + len*: INTEGER; (** valid iff type IN {string, int, lint} **) + string*: String; (** valid iff type IN {string, int, lint, bool, char} **) + view*: Views.View; w*, h*: INTEGER (** valid iff type = view **) + END; + + Formatter* = RECORD + rider-: TextModels.Writer + END; + + + (** Scanner **) + + PROCEDURE ^ (VAR s: Scanner) SetPos* (pos: INTEGER), NEW; + PROCEDURE ^ (VAR s: Scanner) SetOpts* (opts: SET), NEW; + PROCEDURE ^ (VAR s: Scanner) Skip* (OUT ch: CHAR), NEW; + PROCEDURE ^ (VAR s: Scanner) Scan*, NEW; + + + PROCEDURE Get (VAR s: Scanner; OUT ch: CHAR); + BEGIN + s.rider.ReadChar(ch) + END Get; + + PROCEDURE Real (VAR s: Scanner); + VAR res: INTEGER; ch: CHAR; + BEGIN + s.type := real; + s.string[s.len] := "."; INC(s.len); Get(s, ch); + WHILE ("0" <= ch) & (ch <= "9") & (s.len < LEN(s.string) - 1) DO + s.string[s.len] := ch; INC(s.len); Get(s, ch) + END; + IF (ch = "E") OR (ch = "D") THEN + s.string[s.len] := ch; INC(s.len); Get(s, ch); + IF (ch = "-") OR (ch = "+") THEN s.string[s.len] := ch; INC(s.len); Get(s,ch) END; + WHILE ("0" <= ch) & (ch <= "9") & (s.len < LEN(s.string) - 1) DO + s.string[s.len] := ch; INC(s.len); Get(s, ch) + END + END; + s.string[s.len] := 0X; + Strings.StringToReal(s.string, s.real, res); + IF res # 0 THEN s.type := invalid END + END Real; + + PROCEDURE Integer (VAR s: Scanner); + VAR n, k, res: INTEGER; ch: CHAR; hex: BOOLEAN; + BEGIN + s.type := int; hex := FALSE; ch := s.rider.char; + IF ch = "%" THEN + s.string[s.len] := "%"; INC(s.len); Get(s, ch); n:= 0; + IF ("0" <= ch) & (ch <= "9") THEN + k := ORD(ch) - ORD("0"); + REPEAT + n := 10*n + k; s.string[s.len] := ch; INC(s.len); + Get(s, ch); k := ORD(ch) - ORD("0") + UNTIL (ch < "0") OR (ch > "9") OR (n > (MAX(INTEGER) - k) DIV 10) OR (s.len = LEN(s.string)); + IF ("0" <= ch) & (ch <= "9") THEN s.type := invalid ELSE s.base := n END + ELSE s.type := invalid + END + ELSIF (ch = "H") OR (ch = "X") THEN + hex := TRUE; s.base := 16; + s.string[s.len] := ch; INC(s.len); Get(s, ch) + ELSE + s.base := 10 + END; + s.string[s.len] := 0X; + IF s.type # invalid THEN + Strings.StringToInt(s.string, s.int, res); + IF res = 0 THEN s.type := int; + IF hex THEN (* Strings.StringToLInt(s.string, s.lint, res); ASSERT(res = 0, 100); *) + IF s.int < 0 THEN s.lint := s.int + (LONG(MAX(INTEGER)) + 1) * 2 + ELSE s.lint := s.int + END + ELSE s.lint := s.int + END + ELSIF res = 1 THEN (* INTEGER overflow *) + Strings.StringToLInt(s.string, s.lint, res); + IF res = 0 THEN s.type := lint ELSE s.type := invalid END + ELSE (* syntax error *) + s.type := invalid + END + END + END Integer; + + PROCEDURE Number (VAR s: Scanner; neg: BOOLEAN); + VAR m: INTEGER; ch: CHAR; + BEGIN + s.len := 0; m := 0; ch := s.rider.char; + IF neg THEN s.string[s.len] := "-"; INC(s.len) END; + REPEAT + IF (m > 0) OR (ch # "0") THEN (* ignore leading zeroes *) + s.string[s.len] := ch; INC(s.len); INC(m) + END; + Get(s, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F") + OR (s.len = LEN(s.string) - 1) OR s.rider.eot; + IF (s.len = 0) OR (s.len = 1) & (s.string[0] = "-") THEN (* compensate for ignoring leading zeroes *) + s.string[s.len] := "0"; INC(s.len) + END; + s.string[s.len] := 0X; + IF ch = "." THEN Real(s) ELSE Integer(s) END + END Number; + + PROCEDURE Cardinal (VAR s: Scanner; OUT n: INTEGER); + VAR k: INTEGER; ch: CHAR; + BEGIN + n := 0; s.Skip(ch); + IF ("0" <= ch) & (ch <= "9") THEN + k := ORD(ch) - ORD("0"); + REPEAT + n := n * 10 + k; + Get(s, ch); k := ORD(ch) - ORD("0") + UNTIL (ch < "0") OR (ch > "9") OR (n > (MAX(INTEGER) - k) DIV 10); + IF ("0" <= ch) & (ch <= "9") THEN s.type := invalid END + ELSE s.type := invalid + END + END Cardinal; + + PROCEDURE Set (VAR s: Scanner); + VAR n, m: INTEGER; ch: CHAR; + BEGIN + s.type := set; Get(s, ch); s.Skip(ch); s.set := {}; + WHILE ("0" <= ch) & (ch <= "9") & (s.type = set) DO + Cardinal(s, n); s.Skip(ch); + IF (MIN(SET) <= n) & (n <= MAX(SET)) THEN + INCL(s.set, n); + IF ch = "," THEN + Get(s, ch); s.Skip(ch) + ELSIF ch = "." THEN + Get(s, ch); + IF ch = "." THEN + Get(s, ch); s.Skip(ch); Cardinal(s, m); s.Skip(ch); + IF ch = "," THEN Get(s, ch); s.Skip(ch) END; + IF (n <= m) & (m <= MAX(SET)) THEN + WHILE m > n DO INCL(s.set, m); DEC(m) END + ELSE s.type := invalid + END + ELSE s.type := invalid + END + END + ELSE s.type := invalid + END + END; + IF s.type = set THEN + s.Skip(ch); + IF ch = "}" THEN Get(s, ch) ELSE s.type := invalid END + END + END Set; + + PROCEDURE Boolean (VAR s: Scanner); + VAR ch: CHAR; + BEGIN + s.type := bool; Get(s, ch); + IF (ch = "T") OR (ch = "F") THEN + s.Scan; + IF (s.type = string) & (s.string = "TRUE") THEN s.type := bool; s.bool := TRUE + ELSIF (s.type = string) & (s.string = "FALSE") THEN s.type := bool; s.bool := FALSE + ELSE s.type := invalid + END + ELSE s.type := invalid + END + END Boolean; + + PROCEDURE Name (VAR s: Scanner); + VAR max: INTEGER; ch: CHAR; + BEGIN + s.type := string; s.len := 0; ch := s.rider.char; max := LEN(s.string); + REPEAT + s.string[s.len] := ch; INC(s.len); Get(s, ch) + UNTIL + ~( ("0" <= ch) & (ch <= "9") + OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (0C0X <= ch) & (ch <= 0FFX) & (ch # 0D7X) & (ch # 0F7X) + OR acceptUnderscores & (ch = "_")) + OR (s.len = max); + IF (returnQualIdents IN s.opts) & (ch = ".") & (s.len < max) THEN + REPEAT + s.string[s.len] := ch; INC(s.len); Get(s, ch) + UNTIL + ~( ("0" <= ch) & (ch <= "9") + OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (0C0X <= ch) & (ch <= 0FFX) & (ch # 0D7X) & (ch # 0F7X) + OR acceptUnderscores & (ch = "_") ) + OR (s.len = max) + END; + IF s.len = max THEN DEC(s.len); s.type := invalid END; (* ident too long *) + s.string[s.len] := 0X + END Name; + + PROCEDURE DoubleQuotedString (VAR s: Scanner); + VAR max, pos: INTEGER; ch: CHAR; + BEGIN + pos := s.rider.Pos(); + s.type := string; s.len := 0; max := LEN(s.string) - 1; Get(s, ch); + WHILE (ch # '"') & (ch # 0X) & (s.len < max) DO + s.string[s.len] := ch; INC(s.len); + Get(s, ch) + END; + s.string[s.len] := 0X; + IF ch = '"' THEN Get(s, ch) + ELSE s.type := invalid; s.rider.SetPos(pos (* s.rider.Pos() - s.len - 1 *)); Get(s, ch) + END + END DoubleQuotedString; + + PROCEDURE SingleQuotedString (VAR s: Scanner); + VAR max, pos: INTEGER; ch: CHAR; + BEGIN + pos := s.rider.Pos(); + s.type := string; s.len := 0; max := LEN(s.string) - 1; Get(s, ch); + WHILE (ch # "'") & (ch # 0X) & (s.len < max) DO + s.string[s.len] := ch; INC(s.len); + Get(s, ch) + END; + s.string[s.len] := 0X; + IF s.len = 1 THEN s.type := char; s.char := s.string[0] END; + IF ch = "'" THEN Get(s, ch) + ELSE s.type := invalid; s.rider.SetPos(pos (* s.rider.Pos() - s.len - 1 *)); Get(s, ch) + END + END SingleQuotedString; + + PROCEDURE Char (VAR s: Scanner); + VAR ch: CHAR; + BEGIN + ch := s.rider.char; + IF ch # 0X THEN + s.type := char; s.char := ch; s.string[0] := ch; s.string[1] := 0X; Get(s, ch) + ELSE s.type := invalid + END + END Char; + + PROCEDURE View (VAR s: Scanner); + VAR ch: CHAR; + BEGIN + s.type := view; s.view := s.rider.view; s.w := s.rider.w; s.h := s.rider.h; + IF maskViews IN s.opts THEN + IF s.rider.char # TextModels.viewcode THEN + s.type := char; s.char := s.rider.char; s.string[0] := s.char; s.string[1] := 0X + END + END; + Get(s, ch) + END View; + + + PROCEDURE (VAR s: Scanner) ConnectTo* (text: TextModels.Model), NEW; + BEGIN + IF text # NIL THEN + s.rider := text.NewReader(s.rider); s.SetPos(0); s.SetOpts({}) + ELSE + s.rider := NIL + END + END ConnectTo; + + PROCEDURE (VAR s: Scanner) SetPos* (pos: INTEGER), NEW; + BEGIN + s.rider.SetPos(pos); s.start := pos; + s.lines := 0; s.paras := 0; s.type := invalid + END SetPos; + + PROCEDURE (VAR s: Scanner) SetOpts* (opts: SET), NEW; + BEGIN + s.opts := opts + END SetOpts; + + PROCEDURE (VAR s: Scanner) Pos* (): INTEGER, NEW; + BEGIN + RETURN s.rider.Pos() + END Pos; + + PROCEDURE (VAR s: Scanner) Skip* (OUT ch: CHAR), NEW; + VAR c, v: BOOLEAN; + BEGIN + IF s.opts * {returnCtrlChars, returnViews} = {} THEN + ch := s.rider.char; + WHILE ((ch <= " ") OR (ch = TextModels.digitspace) OR (ch = TextModels.nbspace)) + & ~s.rider.eot DO + IF ch = LINE THEN INC(s.lines) + ELSIF ch = PARA THEN INC(s.paras) + END; + Get(s, ch) + END + ELSE + c := returnCtrlChars IN s.opts; + v := returnViews IN s.opts; + ch := s.rider.char; + WHILE ((ch <= " ") OR (ch = TextModels.digitspace) OR (ch = TextModels.nbspace)) + & ~s.rider.eot + & (~c OR (ch # TAB) & (ch # LINE) & (ch # PARA)) + & (~v OR (ch # VIEW) OR (s.rider.view = NIL)) DO + IF ch = LINE THEN INC(s.lines) + ELSIF ch = PARA THEN INC(s.paras) + END; + Get(s, ch) + END + END; + IF ~s.rider.eot THEN s.start := s.rider.Pos() - 1 + ELSE s.start := s.rider.Base().Length(); s.type := eot + END + END Skip; + + PROCEDURE (VAR s: Scanner) Scan*, NEW; + VAR sign, neg: BOOLEAN; ch: CHAR; + BEGIN + s.Skip(ch); + IF s.type # eot THEN + neg := (ch = "-"); sign := neg OR (ch = "+"); + IF sign THEN s.char := ch; Get(s, ch) END; + IF ("0" <= ch) & (ch <= "9") THEN Number(s, neg) + ELSIF sign THEN s.type := char; (* return prefetched sign w/o trailing number *) + s.string[0] := s.char; s.string[1] := 0X + ELSE + CASE ch OF + | "A" .. "Z", "a" .. "z", 0C0X .. 0D6X, 0D8X .. 0F6X, 0F8X .. 0FFX: Name(s) + | '"': DoubleQuotedString(s) + | "'": SingleQuotedString(s) + | TAB: s.type := tab; Get(s, ch) + | LINE: s.type := line; Get(s, ch) + | PARA: s.type := para; Get(s, ch) + | VIEW: + IF s.rider.view # NIL THEN View(s) ELSE Char(s) END + | "{": + IF interpretSets IN s.opts THEN Set(s) ELSE Char(s) END + | "$": + IF interpretBools IN s.opts THEN Boolean(s) ELSE Char(s) END + | "_": + IF acceptUnderscores THEN Name(s) ELSE Char(s) END + ELSE Char(s) + END + END + END + END Scan; + + + (** scanning utilities **) + + PROCEDURE IsQualIdent* (IN s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; ch: CHAR; + BEGIN + ch := s[0]; i := 1; + IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (0C0X <= ch) & (ch <= 0FFX) & (ch # 0D0X) & (ch # 0D7X) & (ch # 0F7X) THEN + REPEAT + ch := s[i]; INC(i) + UNTIL + ~( ("0" <= ch) & (ch <= "9") + OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (0C0X <= ch) & (ch <= 0FFX) & (ch # 0D0X) & (ch # 0D7X) & (ch # 0F7X) + OR (ch = "_") ); + IF ch = "." THEN + INC(i); + REPEAT + ch := s[i]; INC(i) + UNTIL + ~( ("0" <= ch) & (ch <= "9") + OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (0C0X <= ch) & (ch <= 0FFX) & (ch # 0D0X) & (ch # 0D7X) & (ch # 0F7X) + OR (ch = "_") ); + RETURN ch = 0X + ELSE + RETURN FALSE + END + ELSE + RETURN FALSE + END + END IsQualIdent; + + PROCEDURE ScanQualIdent* (VAR s: Scanner; OUT x: ARRAY OF CHAR; OUT done: BOOLEAN); + VAR mod: String; i, j, len, start: INTEGER; ch: CHAR; + BEGIN + done := FALSE; + IF s.type = string THEN + IF IsQualIdent(s.string) THEN + IF s.len < LEN(x) THEN + x := s.string$; done := TRUE + END + ELSE + mod := s.string; len := s.len; start := s.start; + s.Scan; + IF (s.type = char) & (s.char = ".") THEN + s.Scan; + IF (s.type = string) & (len + 1 + s.len < LEN(x)) THEN + i := 0; ch := mod[0]; WHILE ch # 0X DO x[i] := ch; INC(i); ch := mod[i] END; + x[i] := "."; INC(i); + j := 0; ch := s.string[0]; + WHILE ch # 0X DO x[i] := ch; INC(i); INC(j); ch := s.string[j] END; + x[i] := 0X; done := TRUE + END + END; + IF ~done THEN s.SetPos(start); s.Scan() END + END + END + END ScanQualIdent; + + + (** Formatter **) + + PROCEDURE ^ (VAR f: Formatter) SetPos* (pos: INTEGER), NEW; + PROCEDURE ^ (VAR f: Formatter) WriteIntForm* (x: LONGINT; + base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN), NEW; + PROCEDURE ^ (VAR f: Formatter) WriteRealForm* (x: REAL; + precision, minW, expW: INTEGER; fillCh: CHAR), NEW; + PROCEDURE ^ (VAR f: Formatter) WriteViewForm* (v: Views.View; w, h: INTEGER), NEW; + + + PROCEDURE (VAR f: Formatter) ConnectTo* (text: TextModels.Model), NEW; + BEGIN + IF text # NIL THEN + f.rider := text.NewWriter(f.rider); f.SetPos(text.Length()) + ELSE + f.rider := NIL + END + END ConnectTo; + + PROCEDURE (VAR f: Formatter) SetPos* (pos: INTEGER), NEW; + BEGIN + f.rider.SetPos(pos) + END SetPos; + + PROCEDURE (VAR f: Formatter) Pos* (): INTEGER, NEW; + BEGIN + RETURN f.rider.Pos() + END Pos; + + + PROCEDURE (VAR f: Formatter) WriteChar* (x: CHAR), NEW; + BEGIN + IF (x >= " ") & (x # 7FX) THEN + f.rider.WriteChar(x) + ELSE + f.rider.WriteChar(" "); + f.WriteIntForm(ORD(x), charCode, 3, "0", showBase); + f.rider.WriteChar(" ") + END + END WriteChar; + + PROCEDURE (VAR f: Formatter) WriteInt* (x: LONGINT), NEW; + BEGIN + f.WriteIntForm(x, decimal, 0, TextModels.digitspace, hideBase) + END WriteInt; + + PROCEDURE (VAR f: Formatter) WriteSString* (x: ARRAY OF SHORTCHAR), NEW; + VAR i: INTEGER; + BEGIN + i := 0; WHILE x[i] # 0X DO f.WriteChar(x[i]); INC(i) END + END WriteSString; + + PROCEDURE (VAR f: Formatter) WriteString* (x: ARRAY OF CHAR), NEW; + VAR i: INTEGER; + BEGIN + i := 0; WHILE x[i] # 0X DO f.WriteChar(x[i]); INC(i) END + END WriteString; + + PROCEDURE (VAR f: Formatter) WriteReal* (x: REAL), NEW; + VAR m: ARRAY 256 OF CHAR; + BEGIN + Strings.RealToString(x, m); f.WriteString(m) + END WriteReal; + + PROCEDURE (VAR f: Formatter) WriteBool* (x: BOOLEAN), NEW; + BEGIN + IF x THEN f.WriteString("$TRUE") ELSE f.WriteString("$FALSE") END + END WriteBool; + + PROCEDURE (VAR f: Formatter) WriteSet* (x: SET), NEW; + VAR i: INTEGER; + BEGIN + f.WriteChar("{"); i := MIN(SET); + WHILE x # {} DO + IF i IN x THEN f.WriteInt(i); EXCL(x, i); + IF (i + 2 <= MAX(SET)) & (i+1 IN x) & (i+2 IN x) THEN f.WriteString(".."); + x := x - {i+1, i+2}; INC(i, 3); + WHILE (i <= MAX(SET)) & (i IN x) DO EXCL(x, i); INC(i) END; + f.WriteInt(i-1) + END; + IF x # {} THEN f.WriteString(", ") END + END; + INC(i) + END; + f.WriteChar("}") + END WriteSet; + + PROCEDURE (VAR f: Formatter) WriteTab*, NEW; + BEGIN + f.rider.WriteChar(TAB) + END WriteTab; + + PROCEDURE (VAR f: Formatter) WriteLn*, NEW; + BEGIN + f.rider.WriteChar(LINE) + END WriteLn; + + PROCEDURE (VAR f: Formatter) WritePara*, NEW; + BEGIN + f.rider.WriteChar(PARA) + END WritePara; + + PROCEDURE (VAR f: Formatter) WriteView* (v: Views.View), NEW; + BEGIN + f.WriteViewForm(v, Views.undefined, Views.undefined) + END WriteView; + + + PROCEDURE (VAR f: Formatter) WriteIntForm* (x: LONGINT; + base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN + ), NEW; + VAR s: ARRAY 80 OF CHAR; + BEGIN + Strings.IntToStringForm(x, base, minWidth, fillCh, showBase, s); + f.WriteString(s) + END WriteIntForm; + + PROCEDURE (VAR f: Formatter) WriteRealForm* (x: REAL; + precision, minW, expW: INTEGER; fillCh: CHAR + ), NEW; + VAR s: ARRAY 256 OF CHAR; + BEGIN + Strings.RealToStringForm(x, precision, minW, expW, fillCh, s); f.WriteString(s) + END WriteRealForm; + + + PROCEDURE (VAR f: Formatter) WriteViewForm* (v: Views.View; w, h: INTEGER), NEW; + BEGIN + f.rider.WriteView(v, w, h) + END WriteViewForm; + + PROCEDURE (VAR f: Formatter) WriteParamMsg* (msg, p0, p1, p2: ARRAY OF CHAR), NEW; + VAR s: ARRAY 256 OF CHAR; i: INTEGER; ch: CHAR; + BEGIN + Dialog.MapParamString(msg, p0, p1, p2, s); + i := 0; ch := s[0]; + WHILE ch # 0X DO + IF ch = LINE THEN f.WriteLn + ELSIF ch = PARA THEN f.WritePara + ELSIF ch = TAB THEN f.WriteTab + ELSIF ch >= " " THEN f.WriteChar(ch) + END; + INC(i); ch := s[i] + END + END WriteParamMsg; + + PROCEDURE (VAR f: Formatter) WriteMsg* (msg: ARRAY OF CHAR), NEW; + BEGIN + f.WriteParamMsg(msg, "", "", "") + END WriteMsg; + +END TextMappers. diff --git a/Trurl-based/Text/Mod/Models.odc b/Trurl-based/Text/Mod/Models.odc new file mode 100644 index 0000000..871439a Binary files /dev/null and b/Trurl-based/Text/Mod/Models.odc differ diff --git a/Trurl-based/Text/Mod/Models.txt b/Trurl-based/Text/Mod/Models.txt new file mode 100644 index 0000000..dc1e43b --- /dev/null +++ b/Trurl-based/Text/Mod/Models.txt @@ -0,0 +1,2085 @@ +MODULE TextModels; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Models.odc *) + (* DO NOT EDIT *) + +(* re-check alien attributes: project to base attributes? *) +(* support *lists* of attribute extensions? *) +(* support for enumeration of texts within embedded views + - generally: support for enumeration of X-views within a recursive scheme? + - however: Containers already provides a general iteration scheme + -> could add recursion support to Reader later +*) + + IMPORT + Files, Services, Fonts, Ports, Stores, Models, Views, Properties, Containers; + + (* text file format: + + text = 0 CHAR + textoffset INTEGER (> 0) + { run } + -1 CHAR + { char } + + run = attrno BYTE (0..32) + [ attr ] attr.Internalize + ( piece | lpiece | viewref ) + + piece = length INTEGER (> 0) + + lpiece = -length INTEGER (< 0, length MOD 2 = 0) + + viewref = 0 INTEGER + w INTEGER + h INTEGER + view view.Internalize + *) + + CONST + (* unicode* = 1X; *) + viewcode* = 2X; (** code for embedded views **) + tab* = 9X; line* = 0DX; para* = 0EX; (** tabulator; line and paragraph separator **) + zwspace* = 8BX; nbspace* = 0A0X; digitspace* = 8FX; + hyphen* = 90X; nbhyphen* = 91X; softhyphen* = 0ADX; + + (** Pref.opts, options of text-aware views **) + maskChar* = 0; hideable* = 1; + + (** Prop.known/valid/readOnly **) + offset* = 0; code* = 1; + + (** InfoMsg.op **) + store* = 0; + + (** UpdateMsg.op **) + replace* = 0; insert* = 1; delete* = 2; + + (* EditOp.mode *) + deleteRange = 0; moveBuf = 1; writeSChar = 2; writeChar = 3; writeView = 4; + + dictSize = 32; + + point = Ports.point; + defW = 64 * point; defH = 32 * point; + + (* embedding limits - don't increase maxHeight w/o checking TextViews.StdView *) + minWidth = 5 * point; maxWidth = MAX(INTEGER) DIV 2; + minHeight = 5 * point; maxHeight = 1500 * point; + + minVersion = 0; maxAttrVersion = 0; maxModelVersion = 0; + noLCharStdModelVersion = 0; maxStdModelVersion = 1; + + cacheWidth = 8; cacheLen = 4096; cacheLine = 128; + + TYPE + Model* = POINTER TO ABSTRACT RECORD (Containers.Model) END; + + Attributes* = POINTER TO EXTENSIBLE RECORD (Stores.Store) + init-: BOOLEAN; (* immutable once init is set *) + color-: Ports.Color; + font-: Fonts.Font; + offset-: INTEGER + END; + + AlienAttributes* = POINTER TO RECORD (Attributes) + store-: Stores.Alien + END; + + Prop* = POINTER TO RECORD (Properties.Property) + offset*: INTEGER; + code*: CHAR + END; + + + Context* = POINTER TO ABSTRACT RECORD (Models.Context) END; + + Pref* = RECORD (Properties.Preference) + opts*: SET; (** preset to {} **) + mask*: CHAR (** valid if maskChar IN opts **) + END; + + + Reader* = POINTER TO ABSTRACT RECORD + eot*: BOOLEAN; + attr*: Attributes; + char*: CHAR; + view*: Views.View; + w*, h*: INTEGER + END; + + Writer* = POINTER TO ABSTRACT RECORD + attr-: Attributes + END; + + + InfoMsg* = RECORD (Models.Message) + op*: INTEGER + END; + + UpdateMsg* = RECORD (Models.UpdateMsg) + op*: INTEGER; + beg*, end*, delta*: INTEGER (** range: [beg, end); length = length' + delta **) + END; + + + Directory* = POINTER TO ABSTRACT RECORD + attr-: Attributes + END; + + + Run = POINTER TO EXTENSIBLE RECORD + prev, next: Run; + len: INTEGER; + attr: Attributes + END; + + LPiece = POINTER TO EXTENSIBLE RECORD (Run) + file: Files.File; + org: INTEGER + END; + + Piece = POINTER TO RECORD (LPiece) END; (* u IS Piece => CHAR run *) + + ViewRef = POINTER TO RECORD (Run) (* u IS ViewRef => View run *) + w, h: INTEGER; + view: Views.View (* embedded view *) + END; + + + PieceCache = RECORD + org: INTEGER; + prev: Run (* Org(prev.next) = org *) + END; + + SpillFile = POINTER TO RECORD + file: Files.File; (* valid if file # NIL *) + len: INTEGER; (* len = file.Length() *) + writer: Files.Writer (* writer.Base() = file *) + END; + + AttrDict = RECORD + len: BYTE; + attr: ARRAY dictSize OF Attributes + END; + + StdModel = POINTER TO RECORD (Model) + len: INTEGER; (* len = sum(u : [trailer.next, trailer) : u.len) *) + id: INTEGER; (* unique (could use SYSTEM.ADR instead ...) *) + era: INTEGER; (* stable era >= k *) + trailer: Run; (* init => trailer # NIL *) + pc: PieceCache; + spill: SpillFile; (* spill file, created lazily, shared with clones *) + rd: Reader (* reader cache *) + END; + + StdContext = POINTER TO RECORD (Context) + text: StdModel; + ref: ViewRef + END; + + StdReader = POINTER TO RECORD (Reader) + base: StdModel; (* base = Base() *) + pos: INTEGER; (* pos = Pos() *) + era: INTEGER; + run: Run; (* era = base.era => Pos(run) + off = pos *) + off: INTEGER; (* era = base.era => 0 <= off < run.len *) + reader: Files.Reader (* file reader cache *) + END; + + StdWriter = POINTER TO RECORD (Writer) + base: StdModel; (* base = Base() *) + (* hasSequencer := base.Domain() = NIL OR base.Domain().GetSequencer() = NIL *) + pos: INTEGER; (* pos = Pos() *) + era: INTEGER; (* relevant iff hasSequencer *) + run: Run (* hasSequencer & era = base.era => Pos(run) = pos *) + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + + MoveOp = POINTER TO RECORD (Stores.Operation) (* MoveStretchFrom *) + (* move src.[beg, end) to dest.pos *) + src: StdModel; + beg, end: INTEGER; + dest: StdModel; + pos: INTEGER + END; + + EditOp = POINTER TO RECORD (Stores.Operation) (* CopyStretchFrom, Delete, WriteXXX *) + mode: INTEGER; + canBunch: BOOLEAN; + text: StdModel; + beg, end: INTEGER; (* op = deleteRange: move text.[beg, end) to *) + pos: INTEGER; + first, last: Run; (* op = moveBuf: move to text.pos; + op = writeView: insert at text.pos*) + len: INTEGER; (* op = moveBuf: length of ; + op = write[L]Char: length of spill file before writing new [long] char *) + attr: Attributes (* op = write[L]Char *) + END; + + AttrList = POINTER TO RECORD + next: AttrList; + len: INTEGER; + attr: Attributes + END; + + SetAttrOp = POINTER TO RECORD (Stores.Operation) (* SetAttr, Modify *) + text: StdModel; + beg: INTEGER; + list: AttrList + END; + + ResizeViewOp = POINTER TO RECORD (Stores.Operation) (* ResizeView *) + text: StdModel; + pos: INTEGER; + ref: ViewRef; + w, h: INTEGER + END; + + ReplaceViewOp = POINTER TO RECORD (Stores.Operation) (* ReplaceView *) + text: StdModel; + pos: INTEGER; + ref: ViewRef; + new: Views.View + END; + + TextCache = RECORD + id: INTEGER; (* id of the text block served by this cache block *) + beg, end: INTEGER; (* [beg .. end) cached, 0 <= end - beg < cacheLen *) + buf: ARRAY cacheLen OF BYTE (* [beg MOD cacheLen .. end MOD cacheLen) *) + END; + Cache = ARRAY cacheWidth OF TextCache; + + VAR + dir-, stdDir-: Directory; + + stdProp: Properties.StdProp; (* temp for NewColor, ... NewWeight *) + prop: Prop; (* temp for NewOffset *) + nextId: INTEGER; + cache: Cache; + + + (** Model **) + + PROCEDURE (m: Model) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + m.Internalize^(rd); IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxModelVersion, thisVersion) + END Internalize; + + PROCEDURE (m: Model) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + m.Externalize^(wr); + wr.WriteVersion(maxModelVersion) + END Externalize; + + + PROCEDURE (m: Model) Length* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (m: Model) NewReader* (old: Reader): Reader, NEW, ABSTRACT; + PROCEDURE (m: Model) NewWriter* (old: Writer): Writer, NEW, ABSTRACT; + PROCEDURE (m: Model) InsertCopy* (pos: INTEGER; m0: Model; beg0, end0: INTEGER), NEW, ABSTRACT; + PROCEDURE (m: Model) Insert* (pos: INTEGER; m0: Model; beg0, end0: INTEGER), NEW, ABSTRACT; + PROCEDURE (m: Model) Delete* (beg, end: INTEGER), NEW, ABSTRACT; + PROCEDURE (m: Model) SetAttr* (beg, end: INTEGER; attr: Attributes), NEW, ABSTRACT; + PROCEDURE (m: Model) Prop* (beg, end: INTEGER): Properties.Property, NEW, ABSTRACT; + PROCEDURE (m: Model) Modify* (beg, end: INTEGER; old, p: Properties.Property), NEW, ABSTRACT; + PROCEDURE (m: Model) ReplaceView* (old, new: Views.View), ABSTRACT; + + PROCEDURE (m: Model) Append* (m0: Model), NEW, ABSTRACT; +(* + BEGIN + ASSERT(m # m0, 20); + m.Insert(m.Length(), m0, 0, m0.Length()) + END Append; +*) + PROCEDURE (m: Model) Replace* (beg, end: INTEGER; m0: Model; beg0, end0: INTEGER), + NEW, ABSTRACT; +(* + VAR script: Stores.Operation; delta: INTEGER; + BEGIN + Models.BeginScript(m, "#System:Replacing", script); + m.Delete(beg, end); + IF beg0 > + m.Insert(beg, m0, beg0, end0); + Models.EndScript(m, script) + END Replace; +*) + + (** Attributes **) + + PROCEDURE (a: Attributes) CopyFrom- (source: Stores.Store), EXTENSIBLE; + (** pre: ~a.init, source.init **) + (** post: a.init **) + BEGIN + WITH source: Attributes DO + ASSERT(~a.init, 20); ASSERT(source.init, 21); a.init := TRUE; + a.color := source.color; a.font := source.font; a.offset := source.offset + END + END CopyFrom; + + PROCEDURE (a: Attributes) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + (** pre: ~a.init **) + (** post: a.init **) + VAR thisVersion: INTEGER; + fprint: INTEGER; face: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER; + BEGIN + ASSERT(~a.init, 20); a.init := TRUE; + a.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxAttrVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadInt(a.color); + rd.ReadInt(fprint); + rd.ReadXString(face); rd.ReadInt(size); rd.ReadSet(style); rd.ReadXInt(weight); + a.font := Fonts.dir.This(face, size, style, weight); + IF a.font.IsAlien() THEN Stores.Report("#System:AlienFont", face, "", "") +(* + ELSIF a.font.Fingerprint() # fprint THEN Stores.Report("#System:AlienFontVersion", face, "", "") +*) + END; + rd.ReadInt(a.offset) + END Internalize; + + PROCEDURE (a: Attributes) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + (** pre: a.init **) + VAR f: Fonts.Font; + BEGIN + ASSERT(a.init, 20); + a.Externalize^(wr); + wr.WriteVersion(maxAttrVersion); + wr.WriteInt(a.color); + f := a.font; +(* + wr.WriteInt(f.Fingerprint()); +*) + wr.WriteInt(0); + wr.WriteXString(f.typeface); wr.WriteInt(f.size); wr.WriteSet(f.style); wr.WriteXInt(f.weight); + wr.WriteInt(a.offset) + END Externalize; + + PROCEDURE (a: Attributes) InitFromProp* (p: Properties.Property), NEW, EXTENSIBLE; + (** pre: ~a.init **) + (** post: a.init, x IN p.valid => x set in a, else x defaults in a **) + VAR def: Fonts.Font; face: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER; + BEGIN + ASSERT(~a.init, 20); a.init := TRUE; + def := Fonts.dir.Default(); + face := def.typeface$; size := def.size; style := def.style; weight := def.weight; + a.color := Ports.defaultColor; a.offset := 0; + WHILE p # NIL DO + WITH p: Properties.StdProp DO + IF Properties.color IN p.valid THEN a.color := p.color.val END; + IF Properties.typeface IN p.valid THEN face := p.typeface END; + IF (Properties.size IN p.valid) + & (Ports.point <= p.size) & (p.size <= 32767 * Ports.point) THEN + size := p.size + END; + IF Properties.style IN p.valid THEN + style := style - p.style.mask + p.style.val * p.style.mask + END; + IF (Properties.weight IN p.valid) & (1 <= p.weight) & (p.weight <= 1000) THEN + weight := p.weight + END + | p: Prop DO + IF offset IN p.valid THEN a.offset := p.offset END + ELSE + END; + p := p.next + END; + a.font := Fonts.dir.This(face, size, style, weight) + END InitFromProp; + + PROCEDURE (a: Attributes) Equals* (b: Attributes): BOOLEAN, NEW, EXTENSIBLE; + (** pre: a.init, b.init **) + BEGIN + ASSERT(a.init, 20); ASSERT((b # NIL) & b.init, 21); + RETURN (a = b) + OR (Services.SameType(a, b)) + & (a.color = b.color) & (a.font = b.font) & (a.offset = b.offset) + END Equals; + + PROCEDURE (a: Attributes) Prop* (): Properties.Property, NEW, EXTENSIBLE; + (** pre: a.init **) + VAR p: Properties.Property; sp: Properties.StdProp; tp: Prop; + BEGIN + ASSERT(a.init, 20); + NEW(sp); + sp.known := {Properties.color .. Properties.weight}; sp.valid := sp.known; + sp.color.val := a.color; + sp.typeface := a.font.typeface$; + sp.size := a.font.size; + sp.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout}; + sp.style.val := a.font.style * sp.style.mask; + sp.weight := a.font.weight; + NEW(tp); + tp.known := {offset}; tp.valid := tp.known; + tp.offset := a.offset; + Properties.Insert(p, tp); Properties.Insert(p, sp); + RETURN p + END Prop; + + PROCEDURE (a: Attributes) ModifyFromProp- (p: Properties.Property), NEW, EXTENSIBLE; + (** pre: ~a.init **) + VAR face: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER; + valid: SET; + BEGIN + face := a.font.typeface; size := a.font.size; + style := a.font.style; weight := a.font.weight; + WHILE p # NIL DO + valid := p.valid; + WITH p: Properties.StdProp DO + IF Properties.color IN valid THEN a.color := p.color.val END; + IF Properties.typeface IN valid THEN + face := p.typeface + END; + IF (Properties.size IN valid) + & (Ports.point <= p.size) & (p.size <= 32767 * Ports.point) THEN + size := p.size + ELSE EXCL(valid, Properties.size) + END; + IF Properties.style IN valid THEN + style := style - p.style.mask + p.style.val * p.style.mask + END; + IF (Properties.weight IN valid) & (1 <= p.weight) & (p.weight <= 1000) THEN + weight := p.weight + ELSE EXCL(valid, Properties.weight) + END; + IF valid - {Properties.typeface .. Properties.weight} # valid THEN + a.font := Fonts.dir.This(face, size, style, weight) + END + | p: Prop DO + IF offset IN valid THEN a.offset := p.offset END + ELSE + END; + p := p.next + END + END ModifyFromProp; + + + PROCEDURE ReadAttr* (VAR rd: Stores.Reader; VAR a: Attributes); + VAR st: Stores.Store; alien: AlienAttributes; + BEGIN + rd.ReadStore(st); ASSERT(st # NIL, 20); + IF st IS Stores.Alien THEN + NEW(alien); alien.store := st(Stores.Alien); Stores.Join(alien, alien.store); + alien.InitFromProp(NIL); a := alien; + Stores.Report("#Text:AlienAttributes", "", "", "") + ELSE a := st(Attributes) + END + END ReadAttr; + + PROCEDURE WriteAttr* (VAR wr: Stores.Writer; a: Attributes); + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + WITH a: AlienAttributes DO wr.WriteStore(a.store) ELSE wr.WriteStore(a) END + END WriteAttr; + + PROCEDURE ModifiedAttr* (a: Attributes; p: Properties.Property): Attributes; + (** pre: a.init **) + (** post: x IN p.valid => x in new attr set to value in p, else set to value in a **) + VAR h: Attributes; + BEGIN + ASSERT(a.init, 20); + h := Stores.CopyOf(a)(Attributes); h.ModifyFromProp(p); + RETURN h + END ModifiedAttr; + + + (** AlienAttributes **) + + PROCEDURE (a: AlienAttributes) Externalize- (VAR wr: Stores.Writer); + BEGIN + HALT(100) + END Externalize; + + PROCEDURE (a: AlienAttributes) CopyFrom- (source: Stores.Store); + BEGIN + a.CopyFrom^(source); + a.store := Stores.CopyOf(source(AlienAttributes).store)(Stores.Alien); + Stores.Join(a, a.store) + END CopyFrom; + + PROCEDURE (a: AlienAttributes) Prop* (): Properties.Property; + BEGIN + RETURN NIL + END Prop; + + PROCEDURE (a: AlienAttributes) ModifyFromProp- (p: Properties.Property); + END ModifyFromProp; + + + (** Prop **) + + 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.offset # q.offset THEN EXCL(valid, offset) END; + IF p.code # q.code THEN EXCL(valid, code) END; + IF p.valid # valid THEN p.valid := valid; equal := FALSE END + END + END IntersectWith; + + + (** Context **) + + PROCEDURE (c: Context) ThisModel* (): Model, ABSTRACT; + PROCEDURE (c: Context) Pos* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (c: Context) Attr* (): Attributes, NEW, ABSTRACT; + + + (** Reader **) + + PROCEDURE (rd: Reader) Base* (): Model, NEW, ABSTRACT; + PROCEDURE (rd: Reader) SetPos* (pos: INTEGER), NEW, ABSTRACT; + PROCEDURE (rd: Reader) Pos* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (rd: Reader) Read*, NEW, ABSTRACT; + PROCEDURE (rd: Reader) ReadPrev*, NEW, ABSTRACT; + + PROCEDURE (rd: Reader) ReadChar* (OUT ch: CHAR), NEW, ABSTRACT; +(* + BEGIN + rd.Read; ch := rd.char + END ReadChar; +*) + PROCEDURE (rd: Reader) ReadPrevChar* (OUT ch: CHAR), NEW, ABSTRACT; +(* + BEGIN + rd.ReadPrev; ch := rd.char + END ReadPrevChar; +*) + PROCEDURE (rd: Reader) ReadView* (OUT v: Views.View), NEW, ABSTRACT; +(* + BEGIN + REPEAT rd.Read UNTIL (rd.view # NIL) OR rd.eot; + v := rd.view + END ReadView; +*) + PROCEDURE (rd: Reader) ReadPrevView* (OUT v: Views.View), NEW, ABSTRACT; +(* + BEGIN + REPEAT rd.ReadPrev UNTIL (rd.view # NIL) OR rd.eot; + v := rd.view + END ReadPrevView; +*) + PROCEDURE (rd: Reader) ReadRun* (OUT attr: Attributes), NEW, ABSTRACT; + (** post: rd.eot OR a # NIL, rd.view = ViewAt(rd.Pos() - 1) **) +(* + VAR a: Attributes; + BEGIN + a := rd.attr; + REPEAT rd.Read UNTIL (rd.attr # a) OR (rd.view # NIL) OR rd.eot; + IF rd.eot THEN attr := NIL ELSE attr := rd.attr END + END ReadRun; +*) + PROCEDURE (rd: Reader) ReadPrevRun* (OUT attr: Attributes), NEW, ABSTRACT; + (** post: rd.eot OR a # NIL, rd.view = ViewAt(rd.Pos()) **) +(* + VAR a: Attributes; + BEGIN + a := rd.attr; + REPEAT rd.ReadPrev UNTIL (rd.attr # a) OR (rd.view # NIL) OR rd.eot; + IF rd.eot THEN attr := NIL ELSE attr := rd.attr END + END ReadPrevRun; +*) + + (** Writer **) + + PROCEDURE (wr: Writer) Base* (): Model, NEW, ABSTRACT; + PROCEDURE (wr: Writer) SetPos* (pos: INTEGER), NEW, ABSTRACT; + PROCEDURE (wr: Writer) Pos* (): INTEGER, NEW, ABSTRACT; + (* PROCEDURE (wr: Writer) WriteSChar* (ch: SHORTCHAR), NEW, ABSTRACT; *) + PROCEDURE (wr: Writer) WriteChar* (ch: CHAR), NEW, ABSTRACT; + PROCEDURE (wr: Writer) WriteView* (view: Views.View; w, h: INTEGER), NEW, ABSTRACT; + + PROCEDURE (wr: Writer) SetAttr* (attr: Attributes), NEW(*, EXTENSIBLE*); + BEGIN + ASSERT(attr # NIL, 20); ASSERT(attr.init, 21); wr.attr := attr + END SetAttr; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (): Model, NEW, ABSTRACT; + + PROCEDURE (d: Directory) NewFromString* (s: ARRAY OF CHAR): Model, NEW, EXTENSIBLE; + VAR m: Model; w: Writer; i: INTEGER; + BEGIN + m := d.New(); w := m.NewWriter(NIL); + i := 0; WHILE s[i] # 0X DO w.WriteChar(s[i]); INC(i) END; + RETURN m + END NewFromString; + + PROCEDURE (d: Directory) SetAttr* (attr: Attributes), NEW, EXTENSIBLE; + BEGIN + ASSERT(attr.init, 20); d.attr := attr + END SetAttr; + + + (* StdModel - foundation *) + + PROCEDURE OpenSpill (s: SpillFile); + BEGIN + s.file := Files.dir.Temp(); s.len := 0; + s.writer := s.file.NewWriter(NIL) + END OpenSpill; + + PROCEDURE Find (t: StdModel; VAR pos: INTEGER; VAR u: Run; VAR off: INTEGER); + (* post: 0 <= pos <= t.len, 0 <= off < u.len, Pos(u) + off = pos *) + (* Read/Write rely on Find to force pos into the legal range *) + VAR v: Run; m: INTEGER; + BEGIN + IF pos < 0 THEN pos := 0 END; + IF pos >= t.len THEN + u := t.trailer; off := 0; t.pc.prev := t.trailer; t.pc.org := 0 + ELSE + v := t.pc.prev.next; m := pos - t.pc.org; + IF m >= 0 THEN + WHILE m >= v.len DO DEC(m, v.len); v := v.next END + ELSE + WHILE m < 0 DO v := v.prev; INC(m, v.len) END + END; + u := v; off := m; t.pc.prev := v.prev; t.pc.org := pos - m + END + END Find; + + PROCEDURE Split (off: INTEGER; VAR u, un: Run); + (* pre: 0 <= off <= u.len *) + (* post: u.len = off, u.len + un.len = u'.len, Pos(u) + u.len = Pos(un) *) + VAR lp: LPiece; sp: Piece; + BEGIN + IF off = 0 THEN un := u; u := un.prev (* "split" at left edge of run *) + ELSIF off < u.len THEN (* u.len > 1 => u IS LPiece; true split *) + WITH u: Piece DO + NEW(sp); sp^ := u^; INC(sp.org, off); + un := sp + ELSE (* u IS LPiece) & ~(u IS Piece) *) + NEW(lp); + lp.prev := u.prev; lp.next := u.next; lp.len := u.len; lp.attr := u.attr; + lp.file := u(LPiece).file; lp.org := u(LPiece).org; + INC(lp.org, 2 * off); + un := lp + END; + DEC(un.len, off); DEC(u.len, un.len); + un.prev := u; un.next := u.next; un.next.prev := un; u.next := un + ELSIF off = u.len THEN un := u.next (* "split" at right edge of run *) + ELSE HALT(100) + END + END Split; + + PROCEDURE Merge (t: StdModel; u: Run; VAR v: Run); + VAR p, q: LPiece; + BEGIN + WITH u: Piece DO + IF (v IS Piece) & ((u.attr = v.attr) OR u.attr.Equals(v.attr)) THEN + p := u; q := v(Piece); + IF (p.file = q.file) & (p.org + p.len = q.org) THEN + IF t.pc.prev = p THEN INC(t.pc.org, q.len) + ELSIF t.pc.prev = q THEN t.pc.prev := t.trailer; t.pc.org := 0 + END; + INC(p.len, q.len); v := v.next + END + END + | u: LPiece DO (* ~(u IS Piece) *) + IF (v IS LPiece) & ~(v IS Piece) & ((u.attr = v.attr) OR u.attr.Equals(v.attr)) THEN + p := u(LPiece); q := v(LPiece); + IF (p.file = q.file) & (p.org + 2 * p.len = q.org) THEN + IF t.pc.prev = p THEN INC(t.pc.org, q.len) + ELSIF t.pc.prev = q THEN t.pc.prev := t.trailer; t.pc.org := 0 + END; + INC(p.len, q.len); v := v.next + END + END + ELSE (* ignore: can't merge ViewRef runs *) + END + END Merge; + + PROCEDURE Splice (un, v, w: Run); (* (u, un) -> (u, v ... w, un) *) + VAR u: Run; + BEGIN + IF v # w.next THEN (* non-empty stretch v ... w *) + u := un.prev; + u.next := v; v.prev := u; un.prev := w; w.next := un + END + END Splice; + + PROCEDURE NewContext (r: ViewRef; text: StdModel): StdContext; + VAR c: StdContext; + BEGIN + NEW(c); c.text := text; c.ref := r; + Stores.Join(text, r.view); + RETURN c + END NewContext; + + PROCEDURE CopyOfPiece (p: LPiece): LPiece; + VAR lp: LPiece; sp: Piece; + BEGIN + WITH p: Piece DO NEW(sp); sp^ := p^; RETURN sp + ELSE + NEW(lp); + lp.prev := p.prev; lp.next := p.next; lp.len := p.len; lp.attr := p.attr; + lp.file := p(LPiece).file; lp.org := p(LPiece).org; + RETURN lp + END + END CopyOfPiece; + + PROCEDURE CopyOfViewRef (r: ViewRef; text: StdModel): ViewRef; + VAR v: ViewRef; + BEGIN + NEW(v); v^ := r^; + v.view := Views.CopyOf(r.view, Views.deep); + v.view.InitContext(NewContext(v, text)); + RETURN v + END CopyOfViewRef; + + PROCEDURE InvalCache (t: StdModel; pos: INTEGER); + VAR n: INTEGER; + BEGIN + n := t.id MOD cacheWidth; + IF cache[n].id = t.id THEN + IF pos <= cache[n].beg THEN cache[n].beg := 0; cache[n].end := 0 + ELSIF pos < cache[n].end THEN cache[n].end := pos + END + END + END InvalCache; + + PROCEDURE StdInit (t: StdModel); + VAR u: Run; + BEGIN + IF t.trailer = NIL THEN + NEW(u); u.len := MAX(INTEGER); u.attr := NIL; u.next := u; u.prev := u; + t.len := 0; t.id := nextId; INC(nextId); t.era := 0; t.trailer := u; + t.pc.prev := u; t.pc.org := 0; + IF t.spill = NIL THEN NEW(t.spill) END + END + END StdInit; + + PROCEDURE CopyOf (src: StdModel; beg, end: INTEGER; dst: StdModel): StdModel; + VAR buf: StdModel; u, v, r, z, zn: Run; ud, vd: INTEGER; + BEGIN + ASSERT(beg < end, 20); + buf := Containers.CloneOf(dst)(StdModel); + ASSERT(buf.Domain() = NIL, 100); + Find(src, beg, u, ud); Find(src, end, v, vd); + z := buf.trailer; r := u; + WHILE r # v DO + WITH r: LPiece DO (* Piece or LPiece *) + zn := CopyOfPiece(r); DEC(zn.len, ud); + IF zn IS Piece THEN INC(zn(LPiece).org, ud) ELSE INC(zn(LPiece).org, 2 * ud) END + | r: ViewRef DO + zn := CopyOfViewRef(r, buf) + ELSE (* ignore *) + END; + z.next := zn; zn.prev := z; z := zn; r := r.next; ud := 0 + END; + IF vd > 0 THEN (* v IS LPiece *) + zn := CopyOfPiece(v(LPiece)); zn.len := vd - ud; + IF zn IS Piece THEN INC(zn(LPiece).org, ud) ELSE INC(zn(LPiece).org, 2 * ud) END; + z.next := zn; zn.prev := z; z := zn + END; + z.next := buf.trailer; buf.trailer.prev := z; + buf.len := end - beg; + RETURN buf + END CopyOf; + + PROCEDURE ProjectionOf (src: Model; beg, end: INTEGER; dst: StdModel): StdModel; + (* rider-conversion to eliminate covariance conflicts in binary operations *) + VAR buf: StdModel; rd: Reader; wr: Writer; + BEGIN + rd := src.NewReader(NIL); rd.SetPos(beg); + buf := Containers.CloneOf(dst)(StdModel); ASSERT(buf.Domain() = NIL, 100); + wr := buf.NewWriter(NIL); + WHILE beg < end DO + INC(beg); + rd.Read; wr.SetAttr(rd.attr); + IF rd.view # NIL THEN + wr.WriteView(Views.CopyOf(rd.view, Views.deep), rd.w, rd.h) + ELSE + wr.WriteChar(rd.char) + END + END; + RETURN buf + END ProjectionOf; + + PROCEDURE Move (src: StdModel; beg, end: INTEGER; dest: StdModel; pos: INTEGER); + VAR pc: PieceCache; view: Views.View; + u, un, v, vn, w, wn: Run; ud, vd, wd: INTEGER; + (*initDom: BOOLEAN; newDom, dom: Stores.Domain;*) + upd: UpdateMsg; neut: Models.NeutralizeMsg; + BEGIN + Models.Broadcast(src, neut); + Find(src, beg, u, ud); Split(ud, u, un); pc := src.pc; + Find(src, end, v, vd); Split(vd, v, vn); src.pc := pc; + Merge(src, u, vn); u.next := vn; vn.prev := u; + DEC(src.len, end - beg); + InvalCache(src, beg); + INC(src.era); + upd.op := delete; upd.beg := beg; upd.end := beg + 1; upd.delta := beg - end; + Models.Broadcast(src, upd); + IF src = dest THEN + IF pos > end THEN DEC(pos, end - beg) END + ELSE + (*newDom := dest.Domain(); initDom := (src.Domain() = NIL) & (newDom # NIL);*) + w := un; + WHILE w # vn DO + (* + IF initDom THEN + dom := w.attr.Domain(); + IF (dom # NIL) & (dom # newDom) THEN w.attr := Stores.CopyOf(w.attr)(Attributes) END; + Stores.InitDomain(w.attr, newDom) + END; + *) + IF ~Stores.Joined(dest, w.attr) THEN + IF ~Stores.Unattached(w.attr) THEN w.attr := Stores.CopyOf(w.attr)(Attributes) END; + Stores.Join(dest, w.attr) + END; + WITH w: ViewRef DO + view := w.view; + (*IF initDom THEN Stores.InitDomain(view, newDom) END;*) + Stores.Join(dest, view); + view.context(StdContext).text := dest + ELSE + END; + w := w.next + END + END; + Find(dest, pos, w, wd); Split(wd, w, wn); Splice(wn, un, v); + v := wn.prev; Merge(dest, v, wn); v.next := wn; wn.prev := v; + wn := w.next; Merge(dest, w, wn); w.next := wn; wn.prev := w; + INC(dest.len, end - beg); + InvalCache(dest, pos); + INC(dest.era); + upd.op := insert; upd.beg := pos; upd.end := pos + end - beg; upd.delta := end - beg; + Models.Broadcast(dest, upd) + END Move; + + + (* StdModel - operations *) + + PROCEDURE (op: MoveOp) Do; + VAR src, dest: StdModel; beg, end, pos: INTEGER; neut: Models.NeutralizeMsg; + BEGIN + src := op.src; beg := op.beg; end := op.end; dest := op.dest; pos := op.pos; + IF src = dest THEN + IF pos < beg THEN + op.pos := end; op.beg := pos; op.end := pos + end - beg + ELSE + op.pos := beg; op.beg := pos - (end - beg); op.end := pos + END + ELSE + Models.Broadcast(op.src, neut); (* destination is neutralized by sequencer *) + op.dest := src; op.src := dest; + op.pos := beg; op.beg := pos; op.end := pos + end - beg + END; + Move(src, beg, end, dest, pos) + END Do; + + PROCEDURE DoMove (name: Stores.OpName; + src: StdModel; beg, end: INTEGER; + dest: StdModel; pos: INTEGER + ); + VAR op: MoveOp; + BEGIN + IF (beg < end) & ((src # dest) OR ~((beg <= pos) & (pos <= end))) THEN + NEW(op); + op.src := src; op.beg := beg; op.end := end; + op.dest := dest; op.pos := pos; + Models.Do(dest, name, op) + END + END DoMove; + + + PROCEDURE (op: EditOp) Do; + VAR text: StdModel; (*newDom, dom: Stores.Domain;*) pc: PieceCache; + u, un, v, vn: Run; sp: Piece; lp: LPiece; r: ViewRef; + ud, vd, beg, end, pos, len: INTEGER; w, h: INTEGER; + upd: UpdateMsg; + BEGIN + text := op.text; + CASE op.mode OF + deleteRange: + beg := op.beg; end := op.end; len := end - beg; + Find(text, beg, u, ud); Split(ud, u, un); pc := text.pc; + Find(text, end, v, vd); Split(vd, v, vn); text.pc := pc; + Merge(text, u, vn); u.next := vn; vn.prev := u; + DEC(text.len, len); + InvalCache(text, beg); + INC(text.era); + op.mode := moveBuf; op.canBunch := FALSE; + op.pos := beg; op.first := un; op.last := v; op.len := len; + upd.op := delete; upd.beg := beg; upd.end := beg + 1; upd.delta := -len; + Models.Broadcast(text, upd) + | moveBuf: + pos := op.pos; + Find(text, pos, u, ud); Split(ud, u, un); Splice(un, op.first, op.last); + INC(text.len, op.len); + InvalCache(text, pos); + INC(text.era); + op.mode := deleteRange; + op.beg := pos; op.end := pos + op.len; + upd.op := insert; upd.beg := pos; upd.end := pos + op.len; upd.delta := op.len; + Models.Broadcast(text, upd) + | writeSChar: + pos := op.pos; + InvalCache(text, pos); + Find(text, pos, u, ud); Split(ud, u, un); + IF (u.attr = op.attr) & (u IS Piece) & (u(Piece).file = text.spill.file) + & (u(Piece).org + u.len = op.len) THEN + INC(u.len); + IF text.pc.org >= pos THEN INC(text.pc.org) END + ELSE + (* + newDom := text.Domain(); + IF newDom # NIL THEN + dom := op.attr.Domain(); + IF (dom # NIL) & (dom # newDom) THEN + op.attr := Stores.CopyOf(op.attr)(Attributes) + END; + Stores.InitDomain(op.attr, newDom) + END; + *) + IF ~Stores.Joined(text, op.attr) THEN + IF ~Stores.Unattached(op.attr) THEN op.attr := Stores.CopyOf(op.attr)(Attributes) END; + Stores.Join(text, op.attr) + END; + NEW(sp); u.next := sp; sp.prev := u; sp.next := un; un.prev := sp; + sp.len := 1; sp.attr := op.attr; + sp.file := text.spill.file; sp.org := op.len; + IF text.pc.org > pos THEN INC(text.pc.org) END + END; + INC(text.len); INC(text.era); + op.mode := deleteRange; + upd.op := insert; upd.beg := pos; upd.end := pos + 1; upd.delta := 1; + Models.Broadcast(text, upd) + | writeChar: + pos := op.pos; + InvalCache(text, pos); + Find(text, pos, u, ud); Split(ud, u, un); + IF (u.attr = op.attr) & (u IS LPiece) & ~(u IS Piece) & (u(LPiece).file = text.spill.file) + & (u(LPiece).org + 2 * u.len = op.len) THEN + INC(u.len); + IF text.pc.org >= pos THEN INC(text.pc.org) END + ELSE + (* + newDom := text.Domain(); + IF newDom # NIL THEN + dom := op.attr.Domain(); + IF (dom # NIL) & (dom # newDom) THEN + op.attr := Stores.CopyOf(op.attr)(Attributes) + END; + Stores.InitDomain(op.attr, newDom) + END; + *) + IF ~Stores.Joined(text, op.attr) THEN + IF ~Stores.Unattached(op.attr) THEN op.attr := Stores.CopyOf(op.attr)(Attributes) END; + Stores.Join(text, op.attr) + END; + NEW(lp); u.next := lp; lp.prev := u; lp.next := un; un.prev := lp; + lp.len := 1; lp.attr := op.attr; + lp.file := text.spill.file; lp.org := op.len; + IF text.pc.org > pos THEN INC(text.pc.org) END + END; + INC(text.len); INC(text.era); + op.mode := deleteRange; + upd.op := insert; upd.beg := pos; upd.end := pos + 1; upd.delta := 1; + Models.Broadcast(text, upd) + | writeView: + pos := op.pos; r := op.first(ViewRef); + InvalCache(text, pos); + Find(text, pos, u, ud); Split(ud, u, un); + u.next := r; r.prev := u; r.next := un; un.prev := r; + INC(text.len); INC(text.era); + r.view.InitContext(NewContext(r, text)); + (* Stores.InitDomain(r.view, text.Domain()); *) + Stores.Join(text, r.view); + w := r.w; h := r.h; r.w := defW; r.h := defH; + Properties.PreferredSize(r.view, minWidth, maxWidth, minHeight, maxHeight, defW, defH, + w, h + ); + r.w := w; r.h := h; + op.mode := deleteRange; + upd.op := insert; upd.beg := pos; upd.end := pos + 1; upd.delta := 1; + Models.Broadcast(text, upd) + END + END Do; + + PROCEDURE GetWriteOp (t: StdModel; pos: INTEGER; VAR op: EditOp; VAR bunch: BOOLEAN); + VAR last: Stores.Operation; + BEGIN + last := Models.LastOp(t); + IF (last # NIL) & (last IS EditOp) THEN + op := last(EditOp); + bunch := op.canBunch & (op.end = pos) + ELSE bunch := FALSE + END; + IF bunch THEN + INC(op.end) + ELSE + NEW(op); op.canBunch := TRUE; + op.text := t; op.beg := pos; op.end := pos + 1 + END; + op.pos := pos + END GetWriteOp; + + + PROCEDURE SetPreferredSize (t: StdModel; v: Views.View); + VAR minW, maxW, minH, maxH, w, h: INTEGER; + BEGIN + t.GetEmbeddingLimits(minW, maxW, minH, maxH); + v.context.GetSize(w, h); + Properties.PreferredSize(v, minW, maxW, minH, maxH, w, h, w, h); + v.context.SetSize(w, h) + END SetPreferredSize; + + PROCEDURE (op: SetAttrOp) Do; + VAR t: StdModel; attr: Attributes; z: AttrList; (*checkDom: BOOLEAN;*) + pc: PieceCache; u, un, v, vn: Run; ud, vd, pos, next: INTEGER; + upd: UpdateMsg; + BEGIN + t := op.text; z := op.list; pos := op.beg; (*checkDom := t.Domain() # NIL;*) + WHILE z # NIL DO + next := pos + z.len; + IF z.attr # NIL THEN + Find(t, pos, u, ud); Split(ud, u, un); pc := t.pc; + Find(t, next, v, vd); Split(vd, v, vn); t.pc := pc; + attr := un.attr; + WHILE un # vn DO + un.attr := z.attr; + (* + IF checkDom & (un.attr.Domain() # t.Domain()) THEN + IF un.attr.Domain() # NIL THEN un.attr := Stores.CopyOf(un.attr)(Attributes) END; + Stores.InitDomain(un.attr, t.Domain()) + END; + *) + IF ~Stores.Joined(t, un.attr) THEN + IF ~Stores.Unattached(un.attr) THEN un.attr := Stores.CopyOf(un.attr)(Attributes) END; + Stores.Join(t, un.attr) + END; + Merge(t, u, un); + WITH un: ViewRef DO SetPreferredSize(t, un.view) ELSE END; + IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END + END; + Merge(t, u, un); u.next := un; un.prev := u; + z.attr := attr + END; + pos := next; z := z.next + END; + INC(t.era); + upd.op := replace; upd.beg := op.beg; upd.end := pos; upd.delta := 0; + Models.Broadcast(t, upd) + END Do; + + + PROCEDURE (op: ResizeViewOp) Do; + VAR r: ViewRef; w, h: INTEGER; upd: UpdateMsg; + BEGIN + r := op.ref; + w := op.w; h := op.h; op.w := r.w; op.h := r.h; r.w := w; r.h := h; + INC(op.text.era); + upd.op := replace; upd.beg := op.pos; upd.end := op.pos + 1; upd.delta := 0; + Models.Broadcast(op.text, upd) + END Do; + + + PROCEDURE (op: ReplaceViewOp) Do; + VAR new: Views.View; upd: UpdateMsg; + BEGIN + new := op.new; op.new := op.ref.view; op.ref.view := new; + INC(op.text.era); + upd.op := replace; upd.beg := op.pos; upd.end := op.pos + 1; upd.delta := 0; + Models.Broadcast(op.text, upd) + END Do; + + + (* StdModel *) + + PROCEDURE (t: StdModel) InitFrom (source: Containers.Model); + BEGIN + WITH source: StdModel DO + ASSERT(source.trailer # NIL, 20); + t.spill := source.spill; (* reduce no of temp files: share spill files among clones *) + StdInit(t) + END + END InitFrom; + + PROCEDURE WriteCharacters (t: StdModel; VAR wr: Stores.Writer); + VAR r: Files.Reader; u: Run; len: INTEGER; +(* + sp: Properties.StorePref; +*) + buf: ARRAY 1024 OF BYTE; + BEGIN + r := NIL; + u := t.trailer.next; + WHILE u # t.trailer DO + WITH u: Piece DO + r := u.file.NewReader(r); r.SetPos(u.org); + len := u.len; + WHILE len > LEN(buf) DO + r.ReadBytes(buf, 0, LEN(buf)); wr.rider.WriteBytes(buf, 0, LEN(buf)); + DEC(len, LEN(buf)) + END; + r.ReadBytes(buf, 0, len); wr.rider.WriteBytes(buf, 0, len) + | u: LPiece DO (* ~(u IS Piece) *) + r := u.file.NewReader(r); r.SetPos(u.org); + len := 2 * u.len; + WHILE len > LEN(buf) DO + r.ReadBytes(buf, 0, LEN(buf)); wr.rider.WriteBytes(buf, 0, LEN(buf)); + DEC(len, LEN(buf)) + END; + r.ReadBytes(buf, 0, len); wr.rider.WriteBytes(buf, 0, len) + | u: ViewRef DO +(* + sp.view := u.view; Views.HandlePropMsg(u.view, sp); + IF sp.view # NIL THEN wr.WriteSChar(viewcode) END +*) + IF Stores.ExternalizeProxy(u.view) # NIL THEN + wr.WriteSChar(viewcode) + END + END; + u := u.next + END + END WriteCharacters; + + PROCEDURE WriteAttributes (VAR wr: Stores.Writer; t: StdModel; + a: Attributes; VAR dict: AttrDict + ); + VAR k, len: BYTE; + BEGIN + len := dict.len; k := 0; WHILE (k # len) & ~a.Equals(dict.attr[k]) DO INC(k) END; + wr.WriteByte(k); + IF k = len THEN + IF len < dictSize THEN dict.attr[len] := a; INC(dict.len) END; + (* ASSERT(Stores.Joined(t, a)); but bkwd-comp: *) + (* IF a.Domain() # d THEN always copy: bkwd-comp hack to avoid link *) + a := Stores.CopyOf(a)(Attributes); (* Stores.InitDomain(a, d); *) Stores.Join(t, a); + (* END; *) + WriteAttr(wr, a) + END + END WriteAttributes; + + PROCEDURE (t: StdModel) Externalize (VAR wr: Stores.Writer); + VAR (*dom: Stores.Domain;*) u, v, un: Run; + attr: Attributes; dict: AttrDict; + org, runlen, pos: INTEGER; lchars: BOOLEAN; + inf: InfoMsg; + BEGIN + t.Externalize^(wr); + StdInit(t); (*dom := t.Domain();*) + wr.WriteVersion(0); + wr.WriteInt(0); org := wr.Pos(); + u := t.trailer.next; v := t.trailer; dict.len := 0; lchars := FALSE; + WHILE u # v DO + attr := u.attr; + WITH u: Piece DO + runlen := u.len; un := u.next; + WHILE (un IS Piece) & un.attr.Equals(attr) DO + INC(runlen, un.len); un := un.next + END; + WriteAttributes(wr, t, attr, dict); wr.WriteInt(runlen) + | u: LPiece DO (* ~(u IS Piece) *) + runlen := 2 * u.len; un := u.next; + WHILE (un IS LPiece) & ~(un IS Piece) & un.attr.Equals(attr) DO + INC(runlen, 2 * un.len); un := un.next + END; + WriteAttributes(wr, t, attr, dict); wr.WriteInt(-runlen); + lchars := TRUE + | u: ViewRef DO + IF Stores.ExternalizeProxy(u.view) # NIL THEN + WriteAttributes(wr, t, attr, dict); wr.WriteInt(0); + wr.WriteInt(u.w); wr.WriteInt(u.h); Views.WriteView(wr, u.view) + END; + un := u.next + END; + u := un + END; + wr.WriteByte(-1); + pos := wr.Pos(); + wr.SetPos(org - 5); + IF lchars THEN wr.WriteVersion(maxStdModelVersion) + ELSE wr.WriteVersion(noLCharStdModelVersion) (* version 0 did not support LONGCHAR *) + END; + wr.WriteInt(pos - org); + wr.SetPos(pos); + WriteCharacters(t, wr); + inf.op := store; Models.Broadcast(t, inf) + END Externalize; + + PROCEDURE (t: StdModel) Internalize (VAR rd: Stores.Reader); + VAR u, un: Run; sp: Piece; lp: LPiece; v: ViewRef; + org, len: INTEGER; ano: BYTE; thisVersion: INTEGER; + attr: Attributes; dict: AttrDict; + BEGIN + ASSERT(t.Domain() = NIL, 20); ASSERT(t.len = 0, 21); + t.Internalize^(rd); IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdModelVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + StdInit(t); + dict.len := 0; u := t.trailer; + rd.ReadInt(len); org := rd.Pos() + len; + rd.ReadByte(ano); + WHILE ano # -1 DO + IF ano = dict.len THEN + ReadAttr(rd, attr); Stores.Join(t, attr); + IF dict.len < dictSize THEN dict.attr[dict.len] := attr; INC(dict.len) END + ELSE + attr := dict.attr[ano] + END; + rd.ReadInt(len); + IF len > 0 THEN (* piece *) + NEW(sp); sp.len := len; sp.attr := attr; + sp.file := rd.rider.Base(); sp.org := org; un := sp; + INC(org, len) + ELSIF len < 0 THEN (* longchar piece *) + len := -len; ASSERT(~ODD(len), 100); + NEW(lp); lp.len := len DIV 2; lp.attr := attr; + lp.file := rd.rider.Base(); lp.org := org; un := lp; + INC(org, len) + ELSE (* len = 0 => embedded view *) + NEW(v); v.len := 1; v.attr := attr; + rd.ReadInt(v.w); rd.ReadInt(v.h); Views.ReadView(rd, v.view); + v.view.InitContext(NewContext(v, t)); + un := v; INC(org) + END; + INC(t.len, un.len); u.next := un; un.prev := u; u := un; + rd.ReadByte(ano) + END; + rd.SetPos(org); + u.next := t.trailer; t.trailer.prev := u + END Internalize; + +(* + PROCEDURE (t: StdModel) PropagateDomain; + VAR u: Run; dom: Stores.Domain; + BEGIN + IF t.Domain() # NIL THEN + u := t.trailer.next; + WHILE u # t.trailer DO + dom := u.attr.Domain(); + IF (dom # NIL) & (dom # t.Domain()) THEN u.attr := Stores.CopyOf(u.attr)(Attributes) END; + Stores.InitDomain(u.attr, t.Domain()); + WITH u: ViewRef DO Stores.InitDomain(u.view, t.Domain()) ELSE END; + u := u.next + END + END + END PropagateDomain; +*) + + PROCEDURE (t: StdModel) GetEmbeddingLimits (OUT minW, maxW, minH, maxH: INTEGER); + BEGIN + minW := minWidth; maxW := maxWidth; minH := minHeight; maxH := maxHeight + END GetEmbeddingLimits; + + + PROCEDURE (t: StdModel) Length (): INTEGER; + BEGIN + StdInit(t); + RETURN t.len + END Length; + + PROCEDURE (t: StdModel) NewReader (old: Reader): Reader; + VAR rd: StdReader; + BEGIN + StdInit(t); + IF (old # NIL) & (old IS StdReader) THEN rd := old(StdReader) ELSE NEW(rd) END; + IF rd.base # t THEN + rd.base := t; rd.era := -1; rd.SetPos(0) + ELSIF rd.pos > t.len THEN + rd.SetPos(t.len) + END; + rd.eot := FALSE; + RETURN rd + END NewReader; + + PROCEDURE (t: StdModel) NewWriter (old: Writer): Writer; + VAR wr: StdWriter; + BEGIN + StdInit(t); + IF (old # NIL) & (old IS StdWriter) THEN wr := old(StdWriter) ELSE NEW(wr) END; + IF (wr.base # t) OR (wr.pos > t.len) THEN + wr.base := t; wr.era := -1; wr.SetPos(t.len) + END; + wr.SetAttr(dir.attr); + RETURN wr + END NewWriter; + + PROCEDURE (t: StdModel) InsertCopy (pos: INTEGER; t0: Model; beg0, end0: INTEGER); + VAR buf: StdModel; + BEGIN + StdInit(t); + ASSERT(0 <= pos, 21); ASSERT(pos <= t.len, 22); + ASSERT(0 <= beg0, 23); ASSERT(beg0 <= end0, 24); ASSERT(end0 <= t0.Length(), 25); + IF beg0 < end0 THEN + WITH t0: StdModel DO buf := CopyOf(t0, beg0, end0, t) + ELSE buf := ProjectionOf(t0, beg0, end0, t) + END; + (* IF t.Domain() # NIL THEN Stores.InitDomain(buf,t.Domain()) END; *) + Stores.Join(t, buf); + DoMove("#System:Copying", buf, 0, buf.len, t, pos) + END + END InsertCopy; + + PROCEDURE (t: StdModel) Insert (pos: INTEGER; t0: Model; beg, end: INTEGER); + BEGIN + StdInit(t); + ASSERT(0 <= pos, 21); ASSERT(pos <= t.len, 22); + ASSERT(0 <= beg, 23); ASSERT(beg <= end, 24); ASSERT(end <= t0.Length(), 25); + IF beg < end THEN + IF (t.Domain() # NIL) & (t0 IS StdModel) & (t0.Domain() = t.Domain()) THEN + DoMove("#System:Moving", t0(StdModel), beg, end, t, pos) + ELSE (* moving across domains *) + t.InsertCopy(pos, t0, beg, end); t0.Delete(beg, end) + END + END + END Insert; + + PROCEDURE (t: StdModel) Append (t0: Model); + VAR len0: INTEGER; + BEGIN + StdInit(t); + ASSERT(t # t0, 20); + len0 := t0.Length(); + IF len0 > 0 THEN + IF (t.Domain() # NIL) & (t0 IS StdModel) & (t0.Domain() = t.Domain()) THEN + DoMove("#Text:Appending", t0(StdModel), 0, len0, t, t.len) + ELSE (* moving across domains *) + t.InsertCopy(t.len, t0, 0, len0); t0.Delete(0, len0) + END + END + END Append; + + PROCEDURE (t: StdModel) Delete (beg, end: INTEGER); + VAR op: EditOp; + BEGIN + StdInit(t); + ASSERT(0 <= beg, 20); ASSERT(beg <= end, 21); ASSERT(end <= t.len, 22); + IF beg < end THEN + NEW(op); op.mode := deleteRange; op.canBunch := FALSE; + op.text := t; op.beg := beg; op.end := end; + Models.Do(t, "#System:Deleting", op) + END + END Delete; + + PROCEDURE (t: StdModel) SetAttr (beg, end: INTEGER; attr: Attributes); + VAR op: SetAttrOp; zp, z: AttrList; + u, v, w: Run; ud, vd: INTEGER; modified: BOOLEAN; + BEGIN + StdInit(t); + ASSERT(0 <= beg, 20); ASSERT(beg <= end, 21); ASSERT(end <= t.len, 22); + IF beg < end THEN + NEW(op); op.text := t; op.beg := beg; + Find(t, beg, u, ud); Find(t, end, v, vd); + IF vd > 0 THEN w := v.next ELSE w := v END; + zp := NIL; modified := FALSE; + WHILE u # w DO + IF u = v THEN INC(ud, v.len - vd) END; + NEW(z); z.len := u.len - ud; z.attr := attr; + IF zp = NIL THEN op.list := z ELSE zp.next:= z END; + zp := z; + modified := modified OR ~u.attr.Equals(attr); + u := u.next; ud := 0 + END; + IF modified THEN Models.Do(t, "#Text:AttributeChange", op) END + END + END SetAttr; + + PROCEDURE (t: StdModel) Prop (beg, end: INTEGER): Properties.Property; + VAR p, q: Properties.Property; tp: Prop; + u, v, w: Run; ud, vd: INTEGER; equal: BOOLEAN; + rd: Reader; + BEGIN + StdInit(t); + ASSERT(0 <= beg, 20); ASSERT(beg <= end, 21); ASSERT(end <= t.len, 22); + IF beg < end THEN + Find(t, beg, u, ud); Find(t, end, v, vd); + IF vd > 0 THEN w := v.next ELSE w := v END; + p := u.attr.Prop(); + u := u.next; + WHILE u # w DO + Properties.Intersect(p, u.attr.Prop(), equal); + u := u.next + END; + IF beg + 1 = end THEN + t.rd := t.NewReader(t.rd); rd := t.rd; + rd.SetPos(beg); rd.Read; + IF (rd.view = NIL) OR (rd.char # viewcode) THEN + q := p; WHILE (q # NIL) & ~(q IS Prop) DO q := q.next END; + IF q # NIL THEN + tp := q(Prop) + ELSE NEW(tp); Properties.Insert(p, tp) + END; + INCL(tp.valid, code); INCL(tp.known, code); INCL(tp.readOnly, code); + tp.code := rd.char + END + END + ELSE p := NIL + END; + RETURN p + END Prop; + + PROCEDURE (t: StdModel) Modify (beg, end: INTEGER; old, p: Properties.Property); + VAR op: SetAttrOp; zp, z: AttrList; + u, v, w: Run; ud, vd: INTEGER; equal, modified: BOOLEAN; + q: Properties.Property; + BEGIN + StdInit(t); + ASSERT(0 <= beg, 20); ASSERT(beg <= end, 21); ASSERT(end <= t.len, 22); + IF (beg < end) & (p # NIL) THEN + NEW(op); op.text := t; op.beg := beg; + Find(t, beg, u, ud); Find(t, end, v, vd); + IF vd > 0 THEN w := v.next ELSE w := v END; + zp := NIL; modified := FALSE; + WHILE u # w DO + IF u = v THEN INC(ud, v.len - vd) END; + IF old # NIL THEN + q := u.attr.Prop(); + Properties.Intersect(q, old, equal); (* q := q * old *) + Properties.Intersect(q, old, equal) (* equal := q = old *) + END; + NEW(z); z.len := u.len - ud; + IF (old = NIL) OR equal THEN + z.attr := ModifiedAttr(u.attr, p); + modified := modified OR ~u.attr.Equals(z.attr) + END; + IF zp = NIL THEN op.list := z ELSE zp.next := z END; + zp := z; + u := u.next; ud := 0 + END; + IF modified THEN Models.Do(t, "#System:Modifying", op) END + END + END Modify; + + PROCEDURE (t: StdModel) ReplaceView (old, new: Views.View); + VAR c: StdContext; op: ReplaceViewOp; + BEGIN + StdInit(t); + ASSERT(old.context # NIL, 20); ASSERT(old.context IS StdContext, 21); + ASSERT(old.context(StdContext).text = t, 22); + ASSERT((new.context = NIL) OR (new.context = old.context), 24); + IF new # old THEN + c := old.context(StdContext); + IF new.context = NIL THEN new.InitContext(c) END; + (* Stores.InitDomain(new, t.Domain()); *) + Stores.Join(t, new); + NEW(op); op.text := t; op.pos := c.Pos(); op.ref := c.ref; op.new := new; + Models.Do(t, "#System:Replacing", op) + END + END ReplaceView; + + PROCEDURE (t: StdModel) CopyFrom- (source: Stores.Store); + BEGIN + StdInit(t); + WITH source: StdModel DO t.InsertCopy(0, source, 0, source.len) END + END CopyFrom; + + PROCEDURE (t: StdModel) Replace (beg, end: INTEGER; t0: Model; beg0, end0: INTEGER); + VAR script: Stores.Operation; + BEGIN + StdInit(t); + ASSERT(0 <= beg, 20); ASSERT(beg <= end, 21); ASSERT(end <= t.len, 22); + ASSERT(0 <= beg0, 23); ASSERT(beg0 <= end0, 24); ASSERT(end0 <= t0.Length(), 25); + ASSERT(t # t0, 26); + Models.BeginScript(t, "#System:Replacing", script); + t.Delete(beg, end); t.Insert(beg, t0, beg0, end0); + Models.EndScript(t, script) + END Replace; + + + (* StdContext *) + + PROCEDURE (c: StdContext) ThisModel (): Model; + BEGIN + RETURN c.text + END ThisModel; + + PROCEDURE (c: StdContext) GetSize (OUT w, h: INTEGER); + BEGIN + w := c.ref.w; h := c.ref.h + END GetSize; + + PROCEDURE (c: StdContext) SetSize (w, h: INTEGER); + VAR t: StdModel; r: ViewRef; op: ResizeViewOp; + BEGIN + t := c.text; r := c.ref; + IF w = Views.undefined THEN w := r.w END; + IF h = Views.undefined THEN h := r.h END; + Properties.PreferredSize(r.view, minWidth, maxWidth, minHeight, maxHeight, r.w, r.h, w, h); + IF (w # r.w) OR (h # r.h) THEN + NEW(op); op.text := t; op.pos := c.Pos(); op.ref := r; op.w := w; op.h := h; + Models.Do(t, "#System:Resizing", op) + END + END SetSize; + + PROCEDURE (c: StdContext) Normalize (): BOOLEAN; + BEGIN + RETURN FALSE + END Normalize; + + PROCEDURE (c: StdContext) Pos (): INTEGER; + VAR t: StdModel; u, r, w: Run; pos: INTEGER; + BEGIN + t := c.text; r := c.ref; + IF t.pc.prev.next # r THEN + u := t.trailer.next; w := t.trailer; pos := 0; + WHILE (u # r) & (u # w) DO INC(pos, u.len); u := u.next END; + ASSERT(u = r, 20); + t.pc.prev := r.prev; t.pc.org := pos + END; + RETURN t.pc.org + END Pos; + + PROCEDURE (c: StdContext) Attr (): Attributes; + BEGIN + RETURN c.ref.attr + END Attr; + + + (* StdReader *) + + PROCEDURE RemapView (rd: StdReader); + VAR p: Pref; + BEGIN + p.opts := {}; Views.HandlePropMsg(rd.view, p); + IF maskChar IN p.opts THEN rd.char := p.mask ELSE rd.char := viewcode END + END RemapView; + + PROCEDURE Reset (rd: StdReader); + VAR t: StdModel; + BEGIN + t := rd.base; + Find(t, rd.pos, rd.run, rd.off); rd.era := t.era + END Reset; + + + PROCEDURE (rd: StdReader) Base (): Model; + BEGIN + RETURN rd.base + END Base; + + PROCEDURE (rd: StdReader) SetPos (pos: INTEGER); + BEGIN + ASSERT(pos >= 0, 20); ASSERT(rd.base # NIL, 21); ASSERT(pos <= rd.base.len, 22); + rd.eot := FALSE; rd.attr := NIL; rd.char := 0X; rd.view := NIL; + IF (rd.pos # pos) OR (rd.run = rd.base.trailer) THEN + rd.pos := pos; rd.era := -1 + END + END SetPos; + + PROCEDURE (rd: StdReader) Pos (): INTEGER; + BEGIN + RETURN rd.pos + END Pos; + + PROCEDURE (rd: StdReader) Read; + VAR t: StdModel; u: Run; n, pos, len: INTEGER; lc: ARRAY 2 OF BYTE; + BEGIN + t := rd.base; + n := t.id MOD cacheWidth; + IF rd.era # t.era THEN Reset(rd) END; + u := rd.run; + WITH u: Piece DO + rd.attr := u.attr; + pos := rd.pos MOD cacheLen; + IF ~((cache[n].id = t.id) & (cache[n].beg <= rd.pos) & (rd.pos < cache[n].end)) THEN + (* cache miss *) + IF cache[n].id # t.id THEN cache[n].id := t.id; cache[n].beg := 0; cache[n].end := 0 END; + len := cacheLine; + IF len > cacheLen - pos THEN len := cacheLen - pos END; + IF len > u.len - rd.off THEN len := u.len - rd.off END; + rd.reader := u.file.NewReader(rd.reader); rd.reader.SetPos(u.org + rd.off); + rd.reader.ReadBytes(cache[n].buf, pos, len); + IF rd.pos = cache[n].end THEN +cache[n].end := rd.pos + len; +(* + INC(cache[n].end, len); +*) + IF cache[n].end - cache[n].beg >= cacheLen THEN + cache[n].beg := cache[n].end - (cacheLen - 1) + END + ELSE cache[n].beg := rd.pos; cache[n].end := rd.pos + len + END + END; + rd.char := CHR(cache[n].buf[pos] MOD 256); rd.view := NIL; + INC(rd.pos); INC(rd.off); + IF rd.off = u.len THEN rd.run := u.next; rd.off := 0 END + | u: LPiece DO (* ~(u IS Piece) *) + rd.attr := u.attr; + rd.reader := u.file.NewReader(rd.reader); rd.reader.SetPos(u.org + rd.off * 2); + rd.reader.ReadBytes(lc, 0, 2); + rd.char := CHR(lc[0] MOD 256 + 256 * (lc[1] + 128)); rd.view := NIL; + IF (cache[n].id = t.id) & (rd.pos = cache[n].end) THEN +cache[n].end := cache[n].end + 1; +IF cache[n].end - cache[n].beg >= cacheLen THEN cache[n].beg := cache[n].beg + 1 END; +(* + INC(cache[n].end); + IF cache[n].end - cache[n].beg >= cacheLen THEN INC(cache[n].beg) END +*) + END; + INC(rd.pos); INC(rd.off); + IF rd.off = u.len THEN rd.run := u.next; rd.off := 0 END + | u: ViewRef DO + rd.attr := u.attr; + rd.view := u.view; rd.w := u.w; rd.h := u.h; RemapView(rd); + IF (cache[n].id = t.id) & (rd.pos = cache[n].end) THEN +cache[n].end := cache[n].end + 1; +IF cache[n].end - cache[n].beg >= cacheLen THEN cache[n].beg := cache[n].beg + 1 END; +(* + INC(cache[n].end); + IF cache[n].end - cache[n].beg >= cacheLen THEN INC(cache[n].beg) END +*) + END; + INC(rd.pos); rd.run := u.next; rd.off := 0 + ELSE + rd.eot := TRUE; rd.attr := NIL; rd.char := 0X; rd.view := NIL + END + END Read; + + PROCEDURE (rd: StdReader) ReadPrev; + VAR t: StdModel; u: Run; n, pos, len: INTEGER; lc: ARRAY 2 OF BYTE; + BEGIN + t := rd.base; + n := t.id MOD cacheWidth; + IF rd.era # t.era THEN Reset(rd) END; + IF rd.off > 0 THEN DEC(rd.off) + ELSIF rd.pos > 0 THEN + rd.run := rd.run.prev; rd.off := rd.run.len - 1 + ELSE rd.run := t.trailer + END; + u := rd.run; + WITH u: Piece DO + rd.attr := u.attr; + DEC(rd.pos); + pos := rd.pos MOD cacheLen; + IF ~((cache[n].id = t.id) & (cache[n].beg <= rd.pos) & (rd.pos < cache[n].end)) THEN + (* cache miss *) + IF cache[n].id # t.id THEN cache[n].id := t.id; cache[n].beg := 0; cache[n].end := 0 END; + len := cacheLine; + IF len > pos + 1 THEN len := pos + 1 END; + IF len > rd.off + 1 THEN len := rd.off + 1 END; + rd.reader := u.file.NewReader(rd.reader); + rd.reader.SetPos(u.org + rd.off - (len - 1)); + rd.reader.ReadBytes(cache[n].buf, pos - (len - 1), len); + IF rd.pos = cache[n].beg - 1 THEN +cache[n].beg := cache[n] .beg - len; +(* + DEC(cache[n].beg, len); +*) + IF cache[n].end - cache[n].beg >= cacheLen THEN + cache[n].end := cache[n].beg + (cacheLen - 1) + END + ELSE cache[n].beg := rd.pos - (len - 1); cache[n].end := rd.pos + 1 + END + END; + rd.char := CHR(cache[n].buf[pos] MOD 256); rd.view := NIL + | u: LPiece DO (* ~(u IS Piece) *) + rd.attr := u.attr; + rd.reader := u.file.NewReader(rd.reader); + rd.reader.SetPos(u.org + 2 * rd.off); + rd.reader.ReadBytes(lc, 0, 2); + rd.char := CHR(lc[0] MOD 256 + 256 * (lc[1] + 128)); rd.view := NIL; + IF (cache[n].id = t.id) & (rd.pos = cache[n].beg) THEN +cache[n].beg := cache[n].beg - 1; +IF cache[n].end - cache[n].beg >= cacheLen THEN cache[n].end := cache[n].end - 1 END +(* + DEC(cache[n].beg); + IF cache[n].end - cache[n].beg >= cacheLen THEN DEC(cache[n].end) END +*) + END; + DEC(rd.pos) + | u: ViewRef DO + rd.attr := u.attr; + rd.view := u.view; rd.w := u.w; rd.h := u.h; RemapView(rd); + IF (cache[n].id = t.id) & (rd.pos = cache[n].beg) THEN +cache[n].beg := cache[n].beg - 1; +IF cache[n].end - cache[n].beg >= cacheLen THEN cache[n].end := cache[n].end - 1 END +(* + DEC(cache[n].beg); + IF cache[n].end - cache[n].beg >= cacheLen THEN DEC(cache[n].end) END +*) + END; + DEC(rd.pos) + ELSE + rd.eot := TRUE; rd.attr := NIL; rd.char := 0X; rd.view := NIL + END + END ReadPrev; + + PROCEDURE (rd: StdReader) ReadChar (OUT ch: CHAR); + BEGIN + rd.Read; ch := rd.char + END ReadChar; + + PROCEDURE (rd: StdReader) ReadPrevChar (OUT ch: CHAR); + BEGIN + rd.ReadPrev; ch := rd.char + END ReadPrevChar; + + PROCEDURE (rd: StdReader) ReadView (OUT v: Views.View); + VAR t: StdModel; u: Run; + BEGIN + t := rd.base; + IF rd.era # t.era THEN Reset(rd) END; + DEC(rd.pos, rd.off); + u := rd.run; + WHILE u IS LPiece DO INC(rd.pos, u.len); u := u.next END; + WITH u: ViewRef DO + INC(rd.pos); rd.run := u.next; rd.off := 0; + rd.attr := u.attr; rd.view := u.view; rd.w := u.w; rd.h := u.h; RemapView(rd) + ELSE (* u = t.trailer *) + ASSERT(u = t.trailer, 100); + rd.run := u; rd.off := 0; + rd.eot := TRUE; rd.attr := NIL; rd.char := 0X; rd.view := NIL + END; + v := rd.view + END ReadView; + + PROCEDURE (rd: StdReader) ReadPrevView (OUT v: Views.View); + VAR t: StdModel; u: Run; + BEGIN + t := rd.base; + IF rd.era # t.era THEN Reset(rd) END; + DEC(rd.pos, rd.off); + u := rd.run.prev; + WHILE u IS LPiece DO DEC(rd.pos, u.len); u := u.prev END; + rd.run := u; rd.off := 0; + WITH u: ViewRef DO + DEC(rd.pos); + rd.attr := u.attr; rd.view := u.view; rd.w := u.w; rd.h := u.h; RemapView(rd) + ELSE (* u = t.trailer *) + ASSERT(u = t.trailer, 100); + rd.eot := TRUE; rd.attr := NIL; rd.char := 0X; rd.view := NIL + END; + v := rd.view + END ReadPrevView; + + PROCEDURE (rd: StdReader) ReadRun (OUT attr: Attributes); + VAR t: StdModel; a0: Attributes; u, trailer: Run; pos: INTEGER; + BEGIN + t := rd.base; + IF rd.era # t.era THEN Reset(rd) END; + a0 := rd.attr; u := rd.run; pos := rd.pos - rd.off; trailer := t.trailer; + WHILE (u.attr = a0) & ~(u IS ViewRef) & (u # trailer) DO + INC(pos, u.len); u := u.next + END; + rd.run := u; rd.pos := pos; rd.off := 0; + rd.Read; + attr := rd.attr + END ReadRun; + + PROCEDURE (rd: StdReader) ReadPrevRun (OUT attr: Attributes); + VAR t: StdModel; a0: Attributes; u, trailer: Run; pos: INTEGER; + BEGIN + t := rd.base; + IF rd.era # t.era THEN Reset(rd) END; + a0 := rd.attr; u := rd.run; pos := rd.pos - rd.off; trailer := t.trailer; + IF u # trailer THEN u := u.prev; DEC(pos, u.len) END; + WHILE (u.attr = a0) & ~(u IS ViewRef) & (u # trailer) DO + u := u.prev; DEC(pos, u.len) + END; + IF u # trailer THEN + rd.run := u.next; rd.pos := pos + u.len; rd.off := 0 + ELSE + rd.run := trailer; rd.pos := 0; rd.off := 0 + END; + rd.ReadPrev; + attr := rd.attr + END ReadPrevRun; + + + (* StdWriter *) + + PROCEDURE WriterReset (wr: StdWriter); + VAR t: StdModel; u: Run; uo: INTEGER; + BEGIN + t := wr.base; + Find(t, wr.pos, u, uo); Split(uo, u, wr.run); wr.era := t.era + END WriterReset; + + PROCEDURE (wr: StdWriter) Base (): Model; + BEGIN + RETURN wr.base + END Base; + + PROCEDURE (wr: StdWriter) SetPos (pos: INTEGER); + BEGIN + ASSERT(pos >= 0, 20); ASSERT(wr.base # NIL, 21); ASSERT(pos <= wr.base.len, 22); + IF wr.pos # pos THEN + wr.pos := pos; wr.era := -1 + END + END SetPos; + + PROCEDURE (wr: StdWriter) Pos (): INTEGER; + BEGIN + RETURN wr.pos + END Pos; + + PROCEDURE WriteSChar (wr: StdWriter; ch: SHORTCHAR); + VAR t: StdModel; u, un: Run; p: Piece; pos, spillPos: INTEGER; + op: EditOp; bunch: BOOLEAN; + BEGIN + t := wr.base; pos := wr.pos; + IF t.spill.file = NIL THEN OpenSpill(t.spill) END; + t.spill.writer.WriteByte(SHORT(ORD(ch))); spillPos := t.spill.len; t.spill.len := spillPos + 1; + IF (t.Domain() = NIL) OR (t.Domain().GetSequencer() = NIL) THEN + (* optimized for speed - writing to unbound text *) + InvalCache(t, pos); + IF wr.era # t.era THEN WriterReset(wr) END; + un := wr.run; u := un.prev; + IF (u.attr # NIL) & u.attr.Equals(wr.attr) & (u IS Piece) & (u(Piece).file = t.spill.file) + & (u(Piece).org + u.len = spillPos) THEN + INC(u.len); + IF t.pc.org >= pos THEN INC(t.pc.org) END + ELSE + NEW(p); u.next := p; p.prev := u; p.next := un; un.prev := p; + p.len := 1; p.attr := wr.attr; + p.file := t.spill.file; p.org := spillPos; + IF t.pc.org > pos THEN INC(t.pc.org) END; + IF ~Stores.Joined(t, p.attr) THEN + IF ~Stores.Unattached(p.attr) THEN p.attr := Stores.CopyOf(p.attr)(Attributes) END; + Stores.Join(t, p.attr) + END + END; + INC(t.era); INC(t.len); + INC(wr.era) + ELSE + GetWriteOp(t, pos, op, bunch); + IF (op.attr = NIL) OR ~op.attr.Equals(wr.attr) THEN op.attr := wr.attr END; + op.mode := writeSChar; (*op.attr := wr.attr;*) op.len := spillPos; + IF bunch THEN Models.Bunch(t) ELSE Models.Do(t, "#System:Inserting", op) END + END; + wr.pos := pos + 1 + END WriteSChar; + + PROCEDURE (wr: StdWriter) WriteChar (ch: CHAR); + VAR t: StdModel; u, un: Run; lp: LPiece; pos, spillPos: INTEGER; + fw: Files.Writer; op: EditOp; bunch: BOOLEAN; + BEGIN + IF (ch >= 20X) & (ch < 7FX) + OR (ch = tab) OR (ch = line) OR (ch = para) + OR (ch = zwspace) OR (ch = digitspace) + OR (ch = hyphen) OR (ch = nbhyphen) OR (ch >= 0A0X) & (ch < 100X) THEN + WriteSChar(wr, SHORT(ch)) (* could inline! *) + ELSIF ch = 200BX THEN wr.WriteChar(zwspace) + ELSIF ch = 2010X THEN wr.WriteChar(hyphen) + ELSIF ch = 2011X THEN wr.WriteChar(nbhyphen) + ELSIF ch >= 100X THEN + t := wr.base; pos := wr.pos; + IF t.spill.file = NIL THEN OpenSpill(t.spill) END; + fw := t.spill.writer; + fw.WriteByte(SHORT(SHORT(ORD(ch)))); + fw.WriteByte(SHORT(SHORT(ORD(ch) DIV 256 - 128))); + spillPos := t.spill.len; t.spill.len := spillPos + 2; + IF (t.Domain() = NIL) OR (t.Domain().GetSequencer() = NIL) THEN + (* optimized for speed - writing to unbound text *) + InvalCache(t, pos); + IF wr.era # t.era THEN WriterReset(wr) END; + un := wr.run; u := un.prev; + IF (u.attr # NIL) & u.attr.Equals(wr.attr) & (u IS LPiece) & ~(u IS Piece) & (u(LPiece).file = t.spill.file) + & (u(LPiece).org + 2 * u.len = spillPos) THEN + INC(u.len); + IF t.pc.org >= pos THEN INC(t.pc.org) END + ELSE + NEW(lp); u.next := lp; lp.prev := u; lp.next := un; un.prev := lp; + lp.len := 1; lp.attr := wr.attr; + lp.file := t.spill.file; lp.org := spillPos; + IF t.pc.org > pos THEN INC(t.pc.org) END; + IF ~Stores.Joined(t, lp.attr) THEN + IF ~Stores.Unattached(lp.attr) THEN lp.attr := Stores.CopyOf(lp.attr)(Attributes) END; + Stores.Join(t, lp.attr) + END + END; + INC(t.era); INC(t.len); + INC(wr.era) + ELSE + GetWriteOp(t, pos, op, bunch); + IF (op.attr = NIL) OR ~op.attr.Equals(wr.attr) THEN op.attr := wr.attr END; + op.mode := writeChar; (*op.attr := wr.attr;*) op.len := spillPos; + IF bunch THEN Models.Bunch(t) ELSE Models.Do(t, "#System:Inserting", op) END + END; + wr.pos := pos + 1 + END + END WriteChar; + + PROCEDURE (wr: StdWriter) WriteView (view: Views.View; w, h: INTEGER); + VAR t: StdModel; u, un: Run; r: ViewRef; pos: INTEGER; + op: EditOp; bunch: BOOLEAN; + BEGIN + ASSERT(view # NIL, 20); ASSERT(view.context = NIL, 21); + t := wr.base; pos := wr.pos; + Stores.Join(t, view); + IF (t.Domain() = NIL) OR (t.Domain().GetSequencer() = NIL) THEN + (* optimized for speed - writing to unbound text *) + IF wr.era # t.era THEN WriterReset(wr) END; + InvalCache(t, pos); + NEW(r); r.len := 1; r.attr := wr.attr; r.view := view; r.w := defW; r.h := defH; + un := wr.run; u := un.prev; u.next := r; r.prev := u; r.next := un; un.prev := r; + IF t.pc.org > pos THEN INC(t.pc.org) END; + INC(t.era); INC(t.len); + view.InitContext(NewContext(r, t)); + Properties.PreferredSize(view, minWidth, maxWidth, minHeight, maxHeight, defW, defH, + w, h + ); + r.w := w; r.h := h; + INC(wr.era) + ELSE + NEW(r); r.len := 1; r.attr := wr.attr; r.view := view; r.w := w; r.h := h; + GetWriteOp(t, pos, op, bunch); + op.mode := writeView; op.first := r; + IF bunch THEN Models.Bunch(t) ELSE Models.Do(t, "#System:Inserting", op) END + END; + INC(wr.pos) + END WriteView; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (): Model; + VAR t: StdModel; + BEGIN + NEW(t); StdInit(t); RETURN t + END New; + + + (** miscellaneous procedures **) +(* + PROCEDURE DumpRuns* (t: Model); + VAR u: Run; n, i, beg, end: INTEGER; name: ARRAY 64 OF CHAR; r: Files.Reader; b: BYTE; + BEGIN + Sub.synch := FALSE; + WITH t: StdModel DO + u := t.trailer.next; + REPEAT + WITH u: Piece DO + Sub.String("short"); + Sub.Int(u.len); + Sub.Char(" "); Sub.IntForm(SYSTEM.ADR(u.file^), 16, 8, "0", FALSE); + Sub.Int(u.org); Sub.Char(" "); + r := u.file.NewReader(NIL); r.SetPos(u.org); i := 0; + WHILE i < 16 DO r.ReadByte(b); Sub.Char(CHR(b)); INC(i) END; + Sub.Ln + | u: LPiece DO (* ~(u IS Piece) *) + Sub.String("long"); + Sub.Int(-u.len); + Sub.Char(" "); Sub.IntForm(SYSTEM.ADR(u.file^), 16, 8, "0", FALSE); + Sub.Int(u.org); Sub.Char(" "); + r := u.file.NewReader(NIL); r.SetPos(u.org); i := 0; + WHILE i < 16 DO r.ReadByte(b); Sub.Char(CHR(b)); INC(i) END; + Sub.Ln + | u: ViewRef DO + Sub.String("view"); + Services.GetTypeName(u.view, name); + Sub.String(name); Sub.Int(u.w); Sub.Int(u.h); Sub.Ln + ELSE + Sub.Char("?"); Sub.Ln + END; + u := u.next + UNTIL u = t.trailer; + n := t.id MOD cacheWidth; + IF cache[n].id = t.id THEN + beg := cache[n].beg; end := cache[n].end; + Sub.Int(beg); Sub.Int(end); Sub.Ln; + Sub.Char("{"); + WHILE beg < end DO Sub.Char(CHR(cache[n].buf[beg MOD cacheLen])); INC(beg) END; + Sub.Char("}"); Sub.Ln + ELSE Sub.String("not cached"); Sub.Ln + END + END + END DumpRuns; +*) + + PROCEDURE NewColor* (a: Attributes; color: Ports.Color): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.color}; stdProp.color.val := color; + RETURN ModifiedAttr(a, stdProp) + END NewColor; + + PROCEDURE NewFont* (a: Attributes; font: Fonts.Font): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.typeface .. Properties.weight}; + stdProp.typeface := font.typeface$; + stdProp.size := font.size; + stdProp.style.val := font.style; + stdProp.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout}; + stdProp.weight := font.weight; + RETURN ModifiedAttr(a, stdProp) + END NewFont; + + PROCEDURE NewOffset* (a: Attributes; offset: INTEGER): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + prop.valid := {0 (*global constant offset masked by param :-( *)}; prop.offset := offset; + RETURN ModifiedAttr(a, prop) + END NewOffset; + + PROCEDURE NewTypeface* (a: Attributes; typeface: Fonts.Typeface): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.typeface}; stdProp.typeface := typeface; + RETURN ModifiedAttr(a, stdProp) + END NewTypeface; + + PROCEDURE NewSize* (a: Attributes; size: INTEGER): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.size}; stdProp.size := size; + RETURN ModifiedAttr(a, stdProp) + END NewSize; + + PROCEDURE NewStyle* (a: Attributes; style: SET): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.style}; stdProp.style.val := style; stdProp.style.mask := -{}; + RETURN ModifiedAttr(a, stdProp) + END NewStyle; + + PROCEDURE NewWeight* (a: Attributes; weight: INTEGER): Attributes; + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + stdProp.valid := {Properties.weight}; stdProp.weight := weight; + RETURN ModifiedAttr(a, stdProp) + END NewWeight; + + + PROCEDURE WriteableChar* (ch: CHAR): BOOLEAN; + (* must be identical to test in (StdWriter)WriteChar - inlined there for efficiency *) + BEGIN + RETURN + (ch >= 20X) & (ch < 7FX) OR + (ch = tab) OR (ch = line) OR (ch = para) OR + (ch = zwspace) OR (ch = digitspace) OR + (ch = hyphen) OR (ch = nbhyphen) OR + (ch >= 0A0X) (* need to augment with test for valid Unicode *) + END WriteableChar; + + + PROCEDURE CloneOf* (source: Model): Model; + BEGIN + ASSERT(source # NIL, 20); + RETURN Containers.CloneOf(source)(Model) + END CloneOf; + + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); ASSERT(d.attr # NIL, 21); ASSERT(d.attr.init, 22); + dir := d + END SetDir; + + + PROCEDURE Init; + VAR d: StdDirectory; a: Attributes; + BEGIN + NEW(a); a.InitFromProp(NIL); + NEW(stdProp); stdProp.known := -{}; + NEW(prop); prop.known := -{}; + NEW(d); stdDir := d; dir := d; d.SetAttr(a) + END Init; + +BEGIN + Init +END TextModels. diff --git a/Trurl-based/Text/Mod/Rulers.odc b/Trurl-based/Text/Mod/Rulers.odc new file mode 100644 index 0000000..1b5f20d Binary files /dev/null and b/Trurl-based/Text/Mod/Rulers.odc differ diff --git a/Trurl-based/Text/Mod/Rulers.txt b/Trurl-based/Text/Mod/Rulers.txt new file mode 100644 index 0000000..f2faa49 --- /dev/null +++ b/Trurl-based/Text/Mod/Rulers.txt @@ -0,0 +1,1676 @@ +(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Rulers.odc *) +(* DO NOT EDIT *) + +MODULE TextRulers; + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + changes = "" + issues = "" + +**) + + (* re-check alien attributes: consider projection semantics *) + + IMPORT + Kernel, Strings, Services, Fonts, Ports, Stores, + Models, Views, Controllers, Properties, Dialog, + TextModels; + + CONST + (** Attributes.valid, Prop.known/valid **) (* Mark.kind *) + first* = 0; left* = 1; right* = 2; lead* = 3; asc* = 4; dsc* = 5; grid* = 6; + opts* = 7; tabs* = 8; + (* additional values for icons held by Mark.kind *) + invalid = -1; + firstIcon = 10; lastIcon = 25; + rightToggle = 10; + gridDec = 12; gridVal = 13; gridInc = 14; + leftFlush = 16; centered = 17; rightFlush = 18; justified = 19; + leadDec = 21; leadVal = 22; leadInc = 23; + pageBrk = 25; + + modeIcons = {leftFlush .. justified}; + validIcons = {rightToggle, gridDec .. gridInc, leftFlush .. justified, leadDec .. leadInc, pageBrk}; + fieldIcons = {gridVal, leadVal}; + + (** Attributes.opts **) + leftAdjust* = 0; rightAdjust* = 1; + (** both: fully justified; none: centered **) + noBreakInside* = 2; pageBreak* = 3; parJoin* = 4; + (** pageBreak of this ruler overrides parJoin request of previous ruler **) + rightFixed* = 5; (** has fixed right border **) + + options = {leftAdjust .. rightFixed}; (* options mask *) + adjMask = {leftAdjust, rightAdjust}; + + (** Attributes.tabType[i] **) + maxTabs* = 32; + centerTab* = 0; rightTab* = 1; + (** both: (reserved); none: leftTab **) + barTab* = 2; + + tabOptions = {centerTab .. barTab}; (* mask for presently valid options *) + + mm = Ports.mm; inch16 = Ports.inch DIV 16; point = Ports.point; + tabBarHeight = 11 * point; scaleHeight = 10 * point; iconBarHeight = 14 * point; + rulerHeight = tabBarHeight + scaleHeight + iconBarHeight; + iconHeight = 10 * point; iconWidth = 12 * point; iconGap = 2 * point; + iconPin = rulerHeight - (iconBarHeight - iconHeight) DIV 2; + + rulerChangeKey = "#Text:RulerChange"; + + minVersion = 0; + maxAttrVersion = 2; maxStyleVersion = 0; maxStdStyleVersion = 0; + maxRulerVersion = 0; maxStdRulerVersion = 0; + + + TYPE + Tab* = RECORD + stop*: INTEGER; + type*: SET + END; + + TabArray* = RECORD (* should be POINTER TO ARRAY OF Tab -- but cannot protect *) + len*: INTEGER; + tab*: ARRAY maxTabs OF Tab + END; + + Attributes* = POINTER TO EXTENSIBLE RECORD (Stores.Store) + init-: BOOLEAN; (* immutable once init holds *) + first-, left-, right-, lead-, asc-, dsc-, grid-: INTEGER; + opts-: SET; + tabs-: TabArray + END; + + AlienAttributes* = POINTER TO RECORD (Attributes) + store-: Stores.Alien + END; + + Style* = POINTER TO ABSTRACT RECORD (Models.Model) + attr-: Attributes + END; + + Ruler* = POINTER TO ABSTRACT RECORD (Views.View) + style-: Style + END; + + + Prop* = POINTER TO RECORD (Properties.Property) + first*, left*, right*, lead*, asc*, dsc*, grid*: INTEGER; + opts*: RECORD val*, mask*: SET END; + tabs*: TabArray + END; + + + UpdateMsg* = RECORD (Models.UpdateMsg) + (** domaincast upon style update **) + style*: Style; + oldAttr*: Attributes + END; + + + Directory* = POINTER TO ABSTRACT RECORD + attr-: Attributes + END; + + + StdStyle = POINTER TO RECORD (Style) END; + + StdRuler = POINTER TO RECORD (Ruler) + sel: INTEGER; (* sel # invalid => sel = kind of selected mark *) + px, py: INTEGER (* sel # invalid => px, py of selected mark *) + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + Mark = RECORD + ruler: StdRuler; + l, r, t, b: INTEGER; + px, py, px0, py0, x, y: INTEGER; + kind, index: INTEGER; + type: SET; (* valid if kind = tabs *) + tabs: TabArray; (* if valid: tabs[index].type = type *) + dirty: BOOLEAN + END; + + SetAttrOp = POINTER TO RECORD (Stores.Operation) + style: Style; + attr: Attributes + END; + + NeutralizeMsg = RECORD (Views.Message) END; + + + VAR + dir-, stdDir-: Directory; + + def: Attributes; + prop: Prop; (* recycled *) + globRd: TextModels.Reader; (* cache for temp reader; beware of reentrance *) + font: Fonts.Font; + + marginGrid, minTabWidth, tabGrid: INTEGER; + + + PROCEDURE ^ DoSetAttrOp (s: Style; attr: Attributes); + + PROCEDURE CopyTabs (IN src: TabArray; OUT dst: TabArray); + (* a TabArray is a 256 byte structure - copying of used parts is much faster than ":= all" *) + VAR i, n: INTEGER; + BEGIN + n := src.len; dst.len := n; + i := 0; WHILE i < n DO dst.tab[i] := src.tab[i]; INC(i) END + END CopyTabs; + + + (** Attributes **) + + PROCEDURE (a: Attributes) CopyFrom- (source: Stores.Store), EXTENSIBLE; + BEGIN + WITH source: Attributes DO + ASSERT(~a.init, 20); ASSERT(source.init, 21); + a.init := TRUE; + a.first := source.first; a.left := source.left; a.right := source.right; + a.lead := source.lead; a.asc := source.asc; a.dsc := source.dsc; a.grid := source.grid; + a.opts := source.opts; + CopyTabs(source.tabs, a.tabs) + END + END CopyFrom; + + PROCEDURE (a: Attributes) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + (** pre: a.init **) + VAR i: INTEGER; typedTabs: BOOLEAN; + BEGIN + ASSERT(a.init, 20); + a.Externalize^(wr); + i := 0; WHILE (i < a.tabs.len) & (a.tabs.tab[i].type = {}) DO INC(i) END; + typedTabs := i < a.tabs.len; + IF typedTabs THEN + wr.WriteVersion(maxAttrVersion) + ELSE + wr.WriteVersion(1) (* versions before 2 had only leftTabs *) + END; + wr.WriteInt(a.first); wr.WriteInt(a.left); wr.WriteInt(a.right); + wr.WriteInt(a.lead); wr.WriteInt(a.asc); wr.WriteInt(a.dsc); wr.WriteInt(a.grid); + wr.WriteSet(a.opts); + wr.WriteXInt(a.tabs.len); + i := 0; WHILE i < a.tabs.len DO wr.WriteInt(a.tabs.tab[i].stop); INC(i) END; + IF typedTabs THEN + i := 0; WHILE i < a.tabs.len DO wr.WriteSet(a.tabs.tab[i].type); INC(i) END + END + END Externalize; + + PROCEDURE (a: Attributes) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + (** pre: ~a.init **) + (** post: a.init **) + VAR thisVersion, i, n, trash: INTEGER; trashSet: SET; + BEGIN + ASSERT(~a.init, 20); a.init := TRUE; + a.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxAttrVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadInt(a.first); rd.ReadInt(a.left); rd.ReadInt(a.right); + rd.ReadInt(a.lead); rd.ReadInt(a.asc); rd.ReadInt(a.dsc); rd.ReadInt(a.grid); + rd.ReadSet(a.opts); + rd.ReadXInt(n); a.tabs.len := MIN(n, maxTabs); + i := 0; WHILE i < a.tabs.len DO rd.ReadInt(a.tabs.tab[i].stop); INC(i) END; + WHILE i < n DO rd.ReadInt(trash); INC(i) END; + IF thisVersion = 0 THEN (* convert from v0 rightFixed to v1 ~rightFixed default *) + INCL(a.opts, rightFixed) + END; + IF thisVersion >= 2 THEN + i := 0; WHILE i < a.tabs.len DO rd.ReadSet(a.tabs.tab[i].type); INC(i) END; + WHILE i < n DO rd.ReadSet(trashSet); INC(i) END + ELSE + i := 0; WHILE i < a.tabs.len DO a.tabs.tab[i].type := {}; INC(i) END + END + END Internalize; + + PROCEDURE Set (p: Prop; opt: INTEGER; VAR x: INTEGER; min, max, new: INTEGER); + BEGIN + IF opt IN p.valid THEN x := MAX(min, MIN(max, new)) END + END Set; + + PROCEDURE ModifyFromProp (a: Attributes; p: Properties.Property); + CONST maxW = 10000*mm; maxH = 32767 * point; + VAR i: INTEGER; type, mask: SET; + BEGIN + WHILE p # NIL DO + WITH p: Prop DO + Set(p, first, a.first, 0, maxW, p.first); + Set(p, left, a.left, 0, maxW, p.left); + Set(p, right, a.right, MAX(a.left, a.first), maxW, p.right); + Set(p, lead, a.lead, 0, maxH, p.lead); + Set(p, asc, a.asc, 0, maxH, p.asc); + Set(p, dsc, a.dsc, 0, maxH - a.asc, p.dsc); + Set(p, grid, a.grid, 1, maxH, p.grid); + IF opts IN p.valid THEN + a.opts := a.opts * (-p.opts.mask) + p.opts.val * p.opts.mask + END; + IF (tabs IN p.valid) & (p.tabs.len >= 0) THEN + IF (p.tabs.len > 0) & (p.tabs.tab[0].stop >= 0) THEN + i := 0; a.tabs.len := MIN(p.tabs.len, maxTabs); + REPEAT + a.tabs.tab[i].stop := p.tabs.tab[i].stop; + type := p.tabs.tab[i].type; mask := tabOptions; + IF type * {centerTab, rightTab} = {centerTab, rightTab} THEN + mask := mask - {centerTab, rightTab} + END; + a.tabs.tab[i].type := a.tabs.tab[i].type * (-mask) + type * mask; + INC(i) + UNTIL (i = a.tabs.len) OR (p.tabs.tab[i].stop < p.tabs.tab[i - 1].stop); + a.tabs.len := i + ELSE a.tabs.len := 0 + END + END + ELSE + END; + p := p.next + END + END ModifyFromProp; + + PROCEDURE (a: Attributes) ModifyFromProp- (p: Properties.Property), NEW, EXTENSIBLE; + BEGIN + ModifyFromProp(a, p) + END ModifyFromProp; + + PROCEDURE (a: Attributes) InitFromProp* (p: Properties.Property), NEW, EXTENSIBLE; + (** pre: ~a.init **) + (** post: (a.init, p # NIL & x IN p.valid) => x set in a, else x defaults in a **) + BEGIN + ASSERT(~a.init, 20); + a.init := TRUE; + a.first := def.first; a.left := def.left; a.right := def.right; + a.lead := def.lead; a.asc := def.asc; a.dsc := def.dsc; a.grid := def.grid; + a.opts := def.opts; + CopyTabs(def.tabs, a.tabs); + ModifyFromProp(a, p) + END InitFromProp; + + PROCEDURE (a: Attributes) Equals* (b: Attributes): BOOLEAN, NEW, EXTENSIBLE; + (** pre: a.init, b.init **) + VAR i: INTEGER; + BEGIN + ASSERT(a.init, 20); ASSERT(b.init, 21); + IF a # b THEN + i := 0; + WHILE (i < a.tabs.len) + & (a.tabs.tab[i].stop = b.tabs.tab[i].stop) + & (a.tabs.tab[i].type = b.tabs.tab[i].type) DO + INC(i) + END; + RETURN (Services.SameType(a, b)) + & (a.first = b.first) & (a.left = b.left) & (a.right = b.right) + & (a.lead = b.lead) & (a.asc = b.asc) & (a.dsc = b.dsc) & (a.grid = b.grid) + & (a.opts = b.opts) & (a.tabs.len = b.tabs.len) & (i = a.tabs.len) + ELSE RETURN TRUE + END + END Equals; + + PROCEDURE (a: Attributes) Prop* (): Properties.Property, NEW, EXTENSIBLE; + (** pre: a.init **) + (** post: x attr in a => x IN p.valid, m set to value of attr in a **) + VAR p: Prop; + BEGIN + ASSERT(a.init, 20); + NEW(p); + p.known := {first .. tabs}; p.valid := p.known; + p.first := a.first; p.left := a.left; p.right := a.right; + p.lead := a.lead; p.asc := a.asc; p.dsc := a.dsc; p.grid := a.grid; + p.opts.val := a.opts; p.opts.mask := options; + CopyTabs(a.tabs, p.tabs); + RETURN p + END Prop; + + + PROCEDURE ReadAttr* (VAR rd: Stores.Reader; OUT a: Attributes); + VAR st: Stores.Store; alien: AlienAttributes; + BEGIN + rd.ReadStore(st); + ASSERT(st # NIL, 100); + IF st IS Stores.Alien THEN + NEW(alien); alien.store := st(Stores.Alien); Stores.Join(alien, alien.store); + alien.InitFromProp(NIL); a := alien + ELSE a := st(Attributes) + END + END ReadAttr; + + PROCEDURE WriteAttr* (VAR wr: Stores.Writer; a: Attributes); + BEGIN + ASSERT(a # NIL, 20); ASSERT(a.init, 21); + WITH a: AlienAttributes DO wr.WriteStore(a.store) ELSE wr.WriteStore(a) END + END WriteAttr; + + PROCEDURE ModifiedAttr* (a: Attributes; p: Properties.Property): Attributes; + (** pre: a.init **) + (** post: x IN p.valid => x in new attr set to value in p, else set to value in a **) + VAR h: Attributes; + BEGIN + ASSERT(a.init, 20); + h := Stores.CopyOf(a)(Attributes); h.ModifyFromProp(p); + RETURN h + END ModifiedAttr; + + + (** AlienAttributes **) + + PROCEDURE (a: AlienAttributes) Externalize- (VAR wr: Stores.Writer); + BEGIN + HALT(100) + END Externalize; + + PROCEDURE (a: AlienAttributes) Internalize- (VAR rd: Stores.Reader); + BEGIN + HALT(100) + END Internalize; + + PROCEDURE (a: AlienAttributes) InitFromProp* (p: Properties.Property); + BEGIN + a.InitFromProp^(NIL) + END InitFromProp; + + PROCEDURE (a: AlienAttributes) ModifyFromProp- (p: Properties.Property); + BEGIN + (* a.InitFromProp^(NIL) *) + a.InitFromProp(NIL) + END ModifyFromProp; + + + (** Style **) + +(* + PROCEDURE (s: Style) PropagateDomain-, EXTENSIBLE; + VAR dom: Stores.Domain; + BEGIN + ASSERT(s.attr # NIL, 20); + dom := s.attr.Domain(); + IF (dom # NIL) & (dom # s.Domain()) THEN s.attr := Stores.CopyOf(s.attr)(Attributes) END; + Stores.InitDomain(s.attr, s.Domain()) + END PropagateDomain; +*) + + PROCEDURE (s: Style) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + s.Externalize^(wr); + wr.WriteVersion(maxStyleVersion); + WriteAttr(wr, s.attr) + END Externalize; + + PROCEDURE (s: Style) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + s.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStyleVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + ReadAttr(rd, s.attr); Stores.Join(s, s.attr) + END Internalize; + + PROCEDURE (s: Style) SetAttr* (attr: Attributes), NEW, EXTENSIBLE; + (** pre: attr.init **) + (** post: s.attr = attr OR s.attr.Equals(attr) **) + BEGIN + ASSERT(attr.init, 20); + DoSetAttrOp(s, attr) + END SetAttr; + + PROCEDURE (s: Style) CopyFrom- (source: Stores.Store), EXTENSIBLE; + BEGIN + WITH source: Style DO + ASSERT(source.attr # NIL, 21); + s.SetAttr(Stores.CopyOf(source.attr)(Attributes)) + (* bkwd-comp hack to avoid link *) + (* copy would not be necessary if Attributes were immutable (and assigned to an Immutable Domain) *) + END + END CopyFrom; + +(* + PROCEDURE (s: Style) InitFrom- (source: Models.Model), EXTENSIBLE; + BEGIN + WITH source: Style DO + ASSERT(source.attr # NIL, 21); + s.SetAttr(Stores.CopyOf(source.attr)(Attributes)) + (* bkwd-comp hack to avoid link *) + END + END InitFrom; +*) + + (** Directory **) + + PROCEDURE (d: Directory) SetAttr* (attr: Attributes), NEW, EXTENSIBLE; + (** pre: attr.init **) + (** post: d.attr = ModifiedAttr(attr, p) + [ p.valid = {opts, tabs}, p.tabs.len = 0, p.opts.mask = {noBreakInside.. parJoin}, p.opts.val = {} ] + **) + VAR p: Prop; + BEGIN + ASSERT(attr.init, 20); + IF attr.tabs.len > 0 THEN + NEW(p); + p.valid := {opts, tabs}; + p.opts.mask := {noBreakInside, pageBreak, parJoin}; p.opts.val := {}; + p.tabs.len := 0; + attr := ModifiedAttr(attr, p) + END; + d.attr := attr + END SetAttr; + + PROCEDURE (d: Directory) NewStyle* (attr: Attributes): Style, NEW, ABSTRACT; + PROCEDURE (d: Directory) New* (style: Style): Ruler, NEW, ABSTRACT; + + PROCEDURE (d: Directory) NewFromProp* (p: Prop): Ruler, NEW, EXTENSIBLE; + BEGIN + RETURN d.New(d.NewStyle(ModifiedAttr(d.attr, p))) + END NewFromProp; + + + PROCEDURE Deposit*; + BEGIN + Views.Deposit(dir.New(NIL)) + END Deposit; + + + (** Ruler **) + + PROCEDURE (r: Ruler) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + ASSERT(r.style # NIL, 20); + r.Externalize^(wr); + wr.WriteVersion(maxRulerVersion); wr.WriteStore(r.style) + END Externalize; + + PROCEDURE (r: Ruler) InitStyle* (s: Style), NEW; + (** pre: r.style = NIL, s # NIL, style.attr # NIL **) + (** post: r.style = s **) + BEGIN + ASSERT((r.style = NIL) OR (r.style = s), 20); + ASSERT(s # NIL, 21); ASSERT(s.attr # NIL, 22); + r.style := s; Stores.Join(r, s) + END InitStyle; + + + PROCEDURE (r: Ruler) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR st: Stores.Store; thisVersion: INTEGER; + BEGIN + r.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxRulerVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadStore(st); + IF st IS Stores.Alien THEN rd.TurnIntoAlien(Stores.alienComponent); RETURN END; + r.InitStyle(st(Style)) + END Internalize; + +(* + PROCEDURE (r: Ruler) InitModel* (m: Models.Model), EXTENSIBLE; + (** pre: r.style = NIL, m # NIL, style.attr # NIL, m IS Style **) + (** post: r.style = m **) + BEGIN + WITH m: Style DO + ASSERT((r.style = NIL) OR (r.style = m), 20); + ASSERT(m # NIL, 21); ASSERT(m.attr # NIL, 22); + r.style := m + ELSE HALT(23) + END + END InitModel; +*) + +(* + PROCEDURE (r: Ruler) PropagateDomain-, EXTENSIBLE; + BEGIN + ASSERT(r.style # NIL, 20); + Stores.InitDomain(r.style, r.Domain()) + END PropagateDomain; +*) + + PROCEDURE CopyOf* (r: Ruler; shallow: BOOLEAN): Ruler; + VAR v: Views.View; + BEGIN + ASSERT(r # NIL, 20); + v := Views.CopyOf(r, shallow); RETURN v(Ruler) + END CopyOf; + + + (** Prop **) + + PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN); + VAR valid: SET; i: INTEGER; c, m: SET; eq: BOOLEAN; + BEGIN + WITH q: Prop DO + valid := p.valid * q.valid; equal := TRUE; + i := 0; + WHILE (i < p.tabs.len) + & (p.tabs.tab[i].stop = q.tabs.tab[i].stop) + & (p.tabs.tab[i].type = q.tabs.tab[i].type) + DO + INC(i) + END; + IF p.first # q.first THEN EXCL(valid, first) END; + IF p.left # q.left THEN EXCL(valid, left) END; + IF p.right # q.right THEN EXCL(valid, right) END; + IF p.lead # q.lead THEN EXCL(valid, lead) END; + IF p.asc # q.asc THEN EXCL(valid, asc) END; + IF p.dsc # q.dsc THEN EXCL(valid, dsc) END; + IF p.grid # q.grid THEN EXCL(valid, grid) END; + Properties.IntersectSelections(p.opts.val, p.opts.mask, q.opts.val, q.opts.mask, c, m, eq); + IF m = {} THEN EXCL(valid, opts) + ELSIF (opts IN valid) & ~eq THEN p.opts.mask := m; equal := FALSE + END; + IF (p.tabs.len # q.tabs.len) OR (q.tabs.len # i) THEN EXCL(valid, tabs) END; + IF p.valid # valid THEN p.valid := valid; equal := FALSE END + END + END IntersectWith; + + + (** ruler construction **) + +(*property-based facade procedures *) + + PROCEDURE SetFirst* (r: Ruler; x: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {first}; prop.first := x; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetFirst; + + PROCEDURE SetLeft* (r: Ruler; x: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {left}; prop.left := x; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetLeft; + + PROCEDURE SetRight* (r: Ruler; x: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {right}; prop.right := x; + prop.opts.mask := {rightFixed}; prop.opts.val := {}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetRight; + + PROCEDURE SetFixedRight* (r: Ruler; x: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {right, opts}; prop.right := x; + prop.opts.mask := {rightFixed}; prop.opts.val := {rightFixed}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetFixedRight; + + + PROCEDURE SetLead* (r: Ruler; h: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {lead}; prop.lead := h; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetLead; + + PROCEDURE SetAsc* (r: Ruler; h: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {asc}; prop.asc := h; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetAsc; + + PROCEDURE SetDsc* (r: Ruler; h: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {dsc}; prop.dsc := h; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetDsc; + + PROCEDURE SetGrid* (r: Ruler; h: INTEGER); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {grid}; prop.grid := h; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetGrid; + + + PROCEDURE SetLeftFlush* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {leftAdjust, rightAdjust}; prop.opts.val := {leftAdjust}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetLeftFlush; + + PROCEDURE SetRightFlush* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {leftAdjust, rightAdjust}; prop.opts.val := {rightAdjust}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetRightFlush; + + PROCEDURE SetCentered* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {leftAdjust, rightAdjust}; prop.opts.val := {}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetCentered; + + PROCEDURE SetJustified* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {leftAdjust, rightAdjust}; prop.opts.val := {leftAdjust, rightAdjust}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetJustified; + + + PROCEDURE SetNoBreakInside* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {noBreakInside}; prop.opts.val := {noBreakInside}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetNoBreakInside; + + PROCEDURE SetPageBreak* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {pageBreak}; prop.opts.val := {pageBreak}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetPageBreak; + + PROCEDURE SetParJoin* (r: Ruler); + BEGIN + ASSERT(r.style # NIL, 20); + prop.valid := {opts}; + prop.opts.mask := {parJoin}; prop.opts.val := {parJoin}; + r.style.SetAttr(ModifiedAttr(r.style.attr, prop)) + END SetParJoin; + + + PROCEDURE AddTab* (r: Ruler; x: INTEGER); + VAR ra: Attributes; i: INTEGER; + BEGIN + ASSERT(r.style # NIL, 20); ra := r.style.attr; i := ra.tabs.len; ASSERT(i < maxTabs, 21); + ASSERT((i = 0) OR (ra.tabs.tab[i - 1].stop < x), 22); + prop.valid := {tabs}; + CopyTabs(ra.tabs, prop.tabs); + prop.tabs.tab[i].stop := x; prop.tabs.tab[i].type := {}; INC(prop.tabs.len); + r.style.SetAttr(ModifiedAttr(ra, prop)) + END AddTab; + + PROCEDURE MakeCenterTab* (r: Ruler); + VAR ra: Attributes; i: INTEGER; + BEGIN + ASSERT(r.style # NIL, 20); ra := r.style.attr; i := ra.tabs.len; ASSERT(i > 0, 21); + prop.valid := {tabs}; + CopyTabs(ra.tabs, prop.tabs); + prop.tabs.tab[i - 1].type := prop.tabs.tab[i - 1].type + {centerTab} - {rightTab}; + r.style.SetAttr(ModifiedAttr(ra, prop)) + END MakeCenterTab; + + PROCEDURE MakeRightTab* (r: Ruler); + VAR ra: Attributes; i: INTEGER; + BEGIN + ASSERT(r.style # NIL, 20); ra := r.style.attr; i := ra.tabs.len; ASSERT(i > 0, 21); + prop.valid := {tabs}; + CopyTabs(ra.tabs, prop.tabs); + prop.tabs.tab[i - 1].type := prop.tabs.tab[i - 1].type - {centerTab} + {rightTab}; + r.style.SetAttr(ModifiedAttr(ra, prop)) + END MakeRightTab; + + PROCEDURE MakeBarTab* (r: Ruler); + VAR ra: Attributes; i: INTEGER; + BEGIN + ASSERT(r.style # NIL, 20); ra := r.style.attr; i := ra.tabs.len; ASSERT(i > 0, 21); + prop.valid := {tabs}; + CopyTabs(ra.tabs, prop.tabs); + prop.tabs.tab[i - 1].type := prop.tabs.tab[i - 1].type + {barTab}; + r.style.SetAttr(ModifiedAttr(ra, prop)) + END MakeBarTab; + + + (* SetAttrOp *) + + PROCEDURE (op: SetAttrOp) Do; + VAR s: Style; attr: Attributes; upd: UpdateMsg; + BEGIN + s := op.style; + attr := s.attr; s.attr := op.attr; op.attr := attr; + (*Stores.InitDomain(s.attr, s.Domain());*) (* Stores.Join(s, s.attr); *) + ASSERT((s.attr=NIL) OR Stores.Joined(s, s.attr), 100); + upd.style := s; upd.oldAttr := attr; Models.Domaincast(s.Domain(), upd) + END Do; + + PROCEDURE DoSetAttrOp (s: Style; attr: Attributes); + VAR op: SetAttrOp; + BEGIN + IF (s.attr # attr) OR ~s.attr.Equals(attr) THEN + (* IF attr.Domain() # s.Domain() THEN attr := Stores.CopyOf(attr)(Attributes) END; *) + IF ~Stores.Joined(s, attr) THEN + IF ~Stores.Unattached(attr) THEN attr := Stores.CopyOf(attr)(Attributes) END; + Stores.Join(s, attr) + END; + NEW(op); op.style := s; op.attr := attr; + Models.Do(s, rulerChangeKey, op) + END + END DoSetAttrOp; + + + (* grid definitions *) + + PROCEDURE MarginGrid (x: INTEGER): INTEGER; + BEGIN + RETURN (x + marginGrid DIV 2) DIV marginGrid * marginGrid + END MarginGrid; + + PROCEDURE TabGrid (x: INTEGER): INTEGER; + BEGIN + RETURN (x + tabGrid DIV 2) DIV tabGrid * tabGrid + END TabGrid; + + + (* nice graphical primitives *) + + PROCEDURE DrawCenteredInt (f: Views.Frame; x, y, n: INTEGER); + VAR sw: INTEGER; s: ARRAY 32 OF CHAR; + BEGIN + Strings.IntToString(n, s); sw := font.StringWidth(s); + f.DrawString(x - sw DIV 2, y, Ports.defaultColor, s, font) + END DrawCenteredInt; + + PROCEDURE DrawNiceRect (f: Views.Frame; l, t, r, b: INTEGER); + VAR u: INTEGER; + BEGIN + u := f.dot; + f.DrawRect(l, t, r - u, b - u, 0, Ports.defaultColor); + f.DrawLine(l + u, b - u, r - u, b - u, u, Ports.grey25); + f.DrawLine(r - u, t + u, r - u, b - u, u, Ports.grey25) + END DrawNiceRect; + + PROCEDURE DrawScale (f: Views.Frame; l, t, r, b, clipL, clipR: INTEGER); + VAR u, h, x, px, sw: INTEGER; i, n, d1, d2: INTEGER; s: ARRAY 32 OF CHAR; + BEGIN + f.DrawRect(l, t, r, b, Ports.fill, Ports.grey12); + u := f.dot; + IF Dialog.metricSystem THEN d1 := 2; d2 := 10 ELSE d1 := 2; d2 := 16 END; + DEC(b, point); + sw := 2*u + font.StringWidth("8888888888"); + x := l + tabGrid; i := 0; n := 0; + WHILE x <= r DO + INC(i); px := TabGrid(x); + IF i = d2 THEN + h := 6*point; i := 0; INC(n); + IF (px >= clipL - sw) & (px < clipR) THEN + Strings.IntToString(n, s); + f.DrawString(px - 2*u - font.StringWidth(s), b - 3*point, Ports.defaultColor, s, font) + END + ELSIF i MOD d1 = 0 THEN + h := 2*point + ELSE + h := 0 + END; + IF (px >= clipL) & (px < clipR) & (h > 0) THEN + f.DrawLine(px, b, px, b - h, 0, Ports.defaultColor) + END; + INC(x, tabGrid) + END + END DrawScale; + + PROCEDURE InvertTabMark (f: Views.Frame; l, t, r, b: INTEGER; type: SET; show: BOOLEAN); + VAR u, u2, u3, yc, i, ih: INTEGER; + BEGIN + u := f.dot; u2 := 2*u; u3 := 3*u; + IF ~ODD((r - l) DIV u) THEN DEC(r, u) END; + yc := l + (r - l) DIV u DIV 2 * u; + IF barTab IN type THEN + f.MarkRect(yc, b - u3, yc + u, b - u2, Ports.fill, Ports.invert, show); + f.MarkRect(yc, b - u, yc + u, b, Ports.fill, Ports.invert, show) + END; + IF centerTab IN type THEN + f.MarkRect(l + u, b - u2, r - u, b - u, Ports.fill, Ports.invert, show) + ELSIF rightTab IN type THEN + f.MarkRect(l, b - u2, yc + u, b - u, Ports.fill, Ports.invert, show) + ELSE + f.MarkRect(yc, b - u2, r, b - u, Ports.fill, Ports.invert, show) + END; + DEC(b, u3); INC(l, u2); DEC(r, u2); + ih := (r - l) DIV 2; + i := b - t; t := b - u; + WHILE (i > 0) & (r > l) DO + DEC(i, u); + f.MarkRect(l, t, r, b, Ports.fill, Ports.invert, show); + IF i <= ih THEN INC(l, u); DEC(r, u) END; + DEC(t, u); DEC(b, u) + END + END InvertTabMark; + + PROCEDURE InvertFirstMark (f: Views.Frame; l, t, r, b: INTEGER; show: BOOLEAN); + VAR u, i, ih: INTEGER; + BEGIN + u := f.dot; + i := b - t; t := b - u; + ih := r - l; + WHILE (i > 0) & (r > l) DO + DEC(i, u); + f.MarkRect(l, t, r, b, Ports.fill, Ports.invert, show); + IF i <= ih THEN DEC(r, u) END; + DEC(t, u); DEC(b, u) + END + END InvertFirstMark; + + PROCEDURE InvertLeftMark (f: Views.Frame; l, t, r, b: INTEGER; show: BOOLEAN); + VAR u, i, ih: INTEGER; + BEGIN + u := f.dot; + i := b - t; b := t + u; + ih := r - l; + WHILE (i > 0) & (r > l) DO + DEC(i, u); + f.MarkRect(l, t, r, b, Ports.fill, Ports.invert, show); + IF i <= ih THEN DEC(r, u) END; + INC(t, u); INC(b, u) + END + END InvertLeftMark; + + PROCEDURE InvertRightMark (f: Views.Frame; l, t, r, b: INTEGER; show: BOOLEAN); + VAR u, i, ih: INTEGER; + BEGIN + u := f.dot; + IF ~ODD((b - t) DIV u) THEN INC(t, u) END; + ih := r - l; l := r - u; + i := b - t; b := t + u; + WHILE (i > 0) & (i > ih) DO + DEC(i, u); + f.MarkRect(l, t, r, b, Ports.fill, Ports.invert, show); + DEC(l, u); + INC(t, u); INC(b, u) + END; + WHILE (i > 0) & (r > l) DO + DEC(i, u); + f.MarkRect(l, t, r, b, Ports.fill, Ports.invert, show); + INC(l, u); + INC(t, u); INC(b, u) + END + END InvertRightMark; + + + (* marks *) + + PROCEDURE SetMark (VAR m: Mark; r: StdRuler; px, py: INTEGER; kind, index: INTEGER); + BEGIN + m.ruler := r; m.kind := kind; + m.px := px; m.py := py; + CASE kind OF + first: + m.l := px; m.r := m.l + 4*point; + m.b := py - 7*point; m.t := m.b - 4*point + | left: + m.l := px; m.r := m.l + 4*point; + m.b := py - 2*point; m.t := m.b - 4*point + | right: + m.r := px; m.l := m.r - 4*point; + m.b := py - 3*point; m.t := m.b - 7*point + | tabs: + m.l := px - 4*point; m.r := m.l + 9*point; + m.b := py - 5*point; m.t := m.b - 6*point; + m.type := r.style.attr.tabs.tab[index].type + | firstIcon .. lastIcon: + m.l := px; m.r := px + iconWidth; + m.t := py; m.b := py + iconHeight + ELSE HALT(100) + END + END SetMark; + + PROCEDURE Try (VAR m: Mark; r: StdRuler; px, py, x, y: INTEGER; kind, index: INTEGER); + BEGIN + IF m.kind = invalid THEN + SetMark(m, r, px, py, kind, index); + IF (m.l - point <= x) & (x < m.r + point) & (m.t - point <= y) & (y < m.b + point) THEN + m.px0 := m.px; m.py0 := m.py; m.x := x; m.y := y; + IF kind = tabs THEN + m.index := index; CopyTabs(r.style.attr.tabs, m.tabs) + END + ELSE + m.kind := invalid + END + END + END Try; + + PROCEDURE InvertMark (VAR m: Mark; f: Views.Frame; show: BOOLEAN); + (* pre: kind # invalid *) + BEGIN + CASE m.kind OF + first: InvertFirstMark(f, m.l, m.t, m.r, m.b, show) + | left: InvertLeftMark(f, m.l, m.t, m.r, m.b, show) + | right: InvertRightMark(f, m.l, m.t, m.r, m.b, show) + | tabs: InvertTabMark(f, m.l, m.t, m.r, m.b, m.type, show) + END + END InvertMark; + + PROCEDURE HiliteMark (VAR m: Mark; f: Views.Frame; show: BOOLEAN); + BEGIN + f.MarkRect(m.l, m.t, m.r - point, m.b - point, Ports.fill, Ports.hilite, show) + END HiliteMark; + + PROCEDURE HiliteThisMark (r: StdRuler; f: Views.Frame; kind: INTEGER; show: BOOLEAN); + VAR m: Mark; px, w, h: INTEGER; + BEGIN + IF (kind # invalid) & (kind IN validIcons) THEN + px := iconGap + (kind - firstIcon) * (iconWidth + iconGap); + r.context.GetSize(w, h); + SetMark(m, r, px, h - iconPin, kind, -1); + HiliteMark(m, f, show) + END + END HiliteThisMark; + + PROCEDURE DrawMark (VAR m: Mark; f: Views.Frame); + (* pre: kind # invalid *) + VAR a: Attributes; l, t, r, b, y, d, e, asc, dsc, fw: INTEGER; i: INTEGER; + w: ARRAY 4 OF INTEGER; + BEGIN + a := m.ruler.style.attr; + l := m.l + 2 * point; t := m.t + 2 * point; r := m.r - 4 * point; b := m.b - 3 * point; + font.GetBounds(asc, dsc, fw); + y := (m.t + m.b + asc) DIV 2; + w[0] := (r - l) DIV 2; w[1] := r - l; w[2] := (r - l) DIV 3; w[3] := (r - l) * 2 DIV 3; + CASE m.kind OF + rightToggle: + IF rightFixed IN a.opts THEN + d := 0; y := (t + b) DIV 2 - point; e := (l + r) DIV 2 + point; + WHILE t < y DO + f.DrawLine(e - d, t, e, t, point, Ports.defaultColor); INC(d, point); INC(t, point) + END; + WHILE t < b DO + f.DrawLine(e - d, t, e, t, point, Ports.defaultColor); DEC(d, point); INC(t, point) + END + ELSE + DEC(b, point); + f.DrawLine(l, t, r, t, point, Ports.defaultColor); + f.DrawLine(l, b, r, b, point, Ports.defaultColor); + f.DrawLine(l, t, l, b, point, Ports.defaultColor); + f.DrawLine(r, t, r, b, point, Ports.defaultColor) + END + | gridDec: + WHILE t < b DO f.DrawLine(l, t, r, t, point, Ports.defaultColor); INC(t, 2 * point) END + | gridVal: + DrawCenteredInt(f, (l + r) DIV 2, y, a.grid DIV point) + | gridInc: + WHILE t < b DO f.DrawLine(l, t, r, t, point, Ports.defaultColor); INC(t, 3 * point) END + | leftFlush: + i := 0; + WHILE t < b DO + d := w[i]; i := (i + 1) MOD LEN(w); + f.DrawLine(l, t, l + d, t, point, Ports.defaultColor); INC(t, 2 * point) + END + | centered: + i := 0; + WHILE t < b DO + d := (r - l - w[i]) DIV 2; i := (i + 1) MOD LEN(w); + f.DrawLine(l + d, t, r - d, t, point, Ports.defaultColor); INC(t, 2 * point) + END + | rightFlush: + i := 0; + WHILE t < b DO + d := w[i]; i := (i + 1) MOD LEN(w); + f.DrawLine(r - d, t, r, t, point, Ports.defaultColor); INC(t, 2 * point) + END + | justified: + WHILE t < b DO f.DrawLine(l, t, r, t, point, Ports.defaultColor); INC(t, 2 * point) END + | leadDec: + f.DrawLine(l, t, l, t + point, point, Ports.defaultColor); INC(t, 2 * point); + WHILE t < b DO f.DrawLine(l, t, r, t, point, Ports.defaultColor); INC(t, 2 * point) END + | leadVal: + DrawCenteredInt(f, (l + r) DIV 2, y, m.ruler.style.attr.lead DIV point) + | leadInc: + f.DrawLine(l, t, l, t + 3 * point, point, Ports.defaultColor); INC(t, 4 * point); + WHILE t < b DO f.DrawLine(l, t, r, t, point, Ports.defaultColor); INC(t, 2 * point) END + | pageBrk: + DEC(b, point); + IF pageBreak IN a.opts THEN + y := (t + b) DIV 2 - point; + f.DrawLine(l, t, l, y, point, Ports.defaultColor); + f.DrawLine(r, t, r, y, point, Ports.defaultColor); + f.DrawLine(l, y, r, y, point, Ports.defaultColor); + INC(y, 2 * point); + f.DrawLine(l, y, r, y, point, Ports.defaultColor); + f.DrawLine(l, y, l, b, point, Ports.defaultColor); + f.DrawLine(r, y, r, b, point, Ports.defaultColor) + ELSE + f.DrawLine(l, t, l, b, point, Ports.defaultColor); + f.DrawLine(r, t, r, b, point, Ports.defaultColor) + END + ELSE + HALT(100) + END; + IF ~(m.kind IN {gridVal, leadVal}) THEN + DrawNiceRect(f, m.l, m.t, m.r, m.b) + END + END DrawMark; + + PROCEDURE GetMark (VAR m: Mark; r: StdRuler; f: Views.Frame; + x, y: INTEGER; canCreate: BOOLEAN + ); + (* pre: ~canCreate OR (f # NIL) *) + VAR a: Attributes; px, w, h: INTEGER; i: INTEGER; + BEGIN + m.kind := invalid; m.dirty := FALSE; + a := r.style.attr; + r.context.GetSize(w, h); + + (* first try scale *) + Try(m, r, a.first, h, x, y, first, 0); + Try(m, r, a.left, h, x, y, left, 0); + IF rightFixed IN a.opts THEN + Try(m, r, a.right, h, x, y, right, 0) + END; + i := 0; + WHILE (m.kind = invalid) & (i < a.tabs.len) DO + Try(m, r, a.tabs.tab[i].stop, h, x, y, tabs, i); + INC(i) + END; + IF (m.kind = invalid) & (y >= h - tabBarHeight) & (a.tabs.len < maxTabs) THEN + i := 0; px := TabGrid(x); + WHILE (i < a.tabs.len) & (a.tabs.tab[i].stop < px) DO INC(i) END; + IF (i = 0) OR (px - a.tabs.tab[i - 1].stop >= minTabWidth) THEN + IF (i = a.tabs.len) OR (a.tabs.tab[i].stop - px >= minTabWidth) THEN + IF canCreate THEN (* set new tab stop, initially at end of list *) + m.kind := tabs; m.index := a.tabs.len; m.dirty := TRUE; + CopyTabs(a.tabs, m.tabs); m.tabs.len := a.tabs.len + 1; + m.tabs.tab[a.tabs.len].stop := px; m.tabs.tab[a.tabs.len].type := {}; + a.tabs.tab[a.tabs.len].stop := px; a.tabs.tab[a.tabs.len].type := {}; + SetMark(m, r, px, h, tabs, m.index); InvertMark(m, f, Ports.show); + m.px0 := m.px; m.py0 := m.py; m.x := x; m.y := y + END + END + END + END; + + (* next try icon bar *) + px := iconGap; i := firstIcon; + WHILE i <= lastIcon DO + IF i IN validIcons THEN + Try(m, r, px, h - iconPin, x, y, i, 0) + END; + INC(px, iconWidth + iconGap); INC(i) + END + END GetMark; + + PROCEDURE SelectMark (r: StdRuler; f: Views.Frame; IN m: Mark); + BEGIN + r.sel := m.kind; r.px := m.px; r.py := m.py + END SelectMark; + + PROCEDURE DeselectMark (r: StdRuler; f: Views.Frame); + BEGIN + HiliteThisMark(r, f, r.sel, Ports.hide); r.sel := invalid + END DeselectMark; + + + (* mark interaction *) + + PROCEDURE Mode (r: StdRuler): INTEGER; + VAR a: Attributes; i: INTEGER; + BEGIN + a := r.style.attr; + IF a.opts * adjMask = {leftAdjust} THEN + i := leftFlush + ELSIF a.opts * adjMask = {} THEN + i := centered + ELSIF a.opts * adjMask = {rightAdjust} THEN + i := rightFlush + ELSE (* a.opts * adjMask = adjMask *) + i := justified + END; + RETURN i + END Mode; + + PROCEDURE GrabMark (VAR m: Mark; r: StdRuler; f: Views.Frame; x, y: INTEGER); + BEGIN + GetMark(m, r, f, x, y, TRUE); + DeselectMark(r, f); + IF m.kind = Mode(r) THEN m.kind := invalid END + END GrabMark; + + PROCEDURE TrackMark (VAR m: Mark; f: Views.Frame; x, y: INTEGER; modifiers: SET); + VAR px, py, w, h: INTEGER; + BEGIN + IF m.kind # invalid THEN + px := m.px + x - m.x; py := m.py + y - m.y; + IF m.kind = tabs THEN + px := TabGrid(px) + ELSIF m.kind IN validIcons THEN + IF (m.l <= x) & (x < m.r) THEN px := 1 ELSE px := 0 END + ELSE + px := MarginGrid(px) + END; + IF m.kind IN {right, tabs} THEN + m.ruler.context.GetSize(w, h); + IF (0 <= y) & (y < h + scaleHeight) OR (Controllers.extend IN modifiers) THEN + py := h + ELSE + py := -1 (* moved mark out of ruler: delete tab stop or fixed right margin *) + END + ELSIF m.kind IN validIcons THEN + IF (m.t <= y) & (y < m.b) THEN py := 1 ELSE py := 0 END + ELSE + py := MarginGrid(py) + END; + IF (m.kind IN {right, tabs}) & ((m.px # px) OR (m.py # py)) THEN + INC(m.x, px - m.px); INC(m.y, py - m.py); + InvertMark(m, f, Ports.hide); SetMark(m, m.ruler, px, py, m.kind, m.index); + InvertMark(m, f, Ports.show); + m.dirty := TRUE + ELSIF (m.kind IN {first, left}) & (m.px # px) THEN + INC(m.x, px - m.px); + InvertMark(m, f, Ports.hide); SetMark(m, m.ruler, px, m.py, m.kind, m.index); + InvertMark(m, f, Ports.show) + ELSIF (m.kind IN validIcons) & (m.px * m.py # px * py) THEN + HiliteMark(m, f, Ports.show); + IF m.kind IN modeIcons THEN HiliteThisMark(m.ruler, f, Mode(m.ruler), Ports.hide) END; + m.px := px; m.py := py + END + END + END TrackMark; + + PROCEDURE ShiftMarks (a: Attributes; p: Prop; mask: SET; x0, dx: INTEGER); + VAR new: SET; i, j, t0, t1: INTEGER; tab0, tab1: TabArray; + BEGIN + new := mask - p.valid; + IF first IN new THEN p.first := a.first END; + IF tabs IN new THEN CopyTabs(a.tabs, p.tabs) END; + p.valid := p.valid + mask; + IF first IN mask THEN INC(p.first, dx) END; + IF tabs IN mask THEN + i := 0; + WHILE (i < p.tabs.len) & (p.tabs.tab[i].stop < x0) DO tab0.tab[i] := p.tabs.tab[i]; INC(i) END; + t0 := i; + t1 := 0; + WHILE i < p.tabs.len DO + tab1.tab[t1].stop := p.tabs.tab[i].stop + dx; + tab1.tab[t1].type := p.tabs.tab[i].type; + INC(t1); INC(i) + END; + i := 0; j := 0; p.tabs.len := 0; + WHILE i < t0 DO (* merge sort *) + WHILE (j < t1) & (tab1.tab[j].stop < tab0.tab[i].stop) DO + p.tabs.tab[p.tabs.len] := tab1.tab[j]; INC(p.tabs.len); INC(j) + END; + IF (j < t1) & (tab1.tab[j].stop = tab0.tab[i].stop) THEN INC(j) END; + p.tabs.tab[p.tabs.len] := tab0.tab[i]; INC(p.tabs.len); INC(i) + END; + WHILE j < t1 DO + p.tabs.tab[p.tabs.len] := tab1.tab[j]; INC(p.tabs.len); INC(j) + END + END + END ShiftMarks; + + PROCEDURE ShiftDependingMarks (VAR m: Mark; p: Prop); + VAR a: Attributes; dx: INTEGER; + BEGIN + a := m.ruler.style.attr; dx := m.px - m.px0; + CASE m.kind OF + first: ShiftMarks(a, p, {tabs}, 0, dx) + | left: ShiftMarks(a, p, {first, tabs}, 0, dx) + | tabs: ShiftMarks(a, p, {tabs}, m.px0, dx) + ELSE + END + END ShiftDependingMarks; + + PROCEDURE AdjustMarks (VAR m: Mark; f: Views.Frame; modifiers: SET); + VAR r: StdRuler; a: Attributes; p: Prop; + g: INTEGER; i, j: INTEGER; shift: BOOLEAN; type: SET; + BEGIN + r := m.ruler; + IF (m.kind # invalid) & (m.kind IN validIcons) + & (m.px = 1) & (m.py = 1) + OR (m.kind # invalid) & ~(m.kind IN validIcons) + & ((m.px # m.px0) OR (m.py # m.py0) + OR (m.kind = tabs) (*(m.tabs.len # r.style.attr.tabs.len)*) ) + THEN + a := r.style.attr; NEW(p); + p.valid := {}; + shift := (Controllers.modify IN modifiers) & (m.tabs.len = r.style.attr.tabs.len); + CASE m.kind OF + first: + p.valid := {first}; p.first := m.px + | left: + p.valid := {left}; p.left := m.px + | right: + IF m.py >= 0 THEN + p.valid := {right}; p.right := m.px + ELSE + p.valid := {opts}; p.opts.val := {}; p.opts.mask := {rightFixed} + END + | tabs: + IF ~m.dirty THEN + p.valid := {tabs}; CopyTabs(m.tabs, p.tabs); + i := m.index; type := m.tabs.tab[i].type; + IF shift THEN + type := type * {barTab}; + IF type = {} THEN type := {barTab} + ELSE type := {} + END; + p.tabs.tab[i].type := p.tabs.tab[i].type - {barTab} + type + ELSE + type := type * {centerTab, rightTab}; + IF type = {} THEN type := {centerTab} + ELSIF type = {centerTab} THEN type := {rightTab} + ELSE type := {} + END; + p.tabs.tab[i].type := p.tabs.tab[i].type - {centerTab, rightTab} + type + END + ELSIF ~shift THEN + p.valid := {tabs}; p.tabs.len := m.tabs.len - 1; + i := 0; + WHILE i < m.index DO p.tabs.tab[i] := m.tabs.tab[i]; INC(i) END; + INC(i); + WHILE i < m.tabs.len DO p.tabs.tab[i - 1] := m.tabs.tab[i]; INC(i) END; + i := 0; + WHILE (i < p.tabs.len) & (p.tabs.tab[i].stop < m.px) DO INC(i) END; + IF (m.px >= MIN(a.first, a.left)) & (m.px <= f.r) & (m.py >= 0) + & ((i = 0) OR (m.px - p.tabs.tab[i - 1].stop >= minTabWidth)) + & ((i = p.tabs.len) OR (p.tabs.tab[i].stop - m.px >= minTabWidth)) THEN + j := p.tabs.len; + WHILE j > i DO p.tabs.tab[j] := p.tabs.tab[j - 1]; DEC(j) END; + p.tabs.tab[i].stop := m.px; p.tabs.tab[i].type := m.tabs.tab[m.index].type; + INC(p.tabs.len) + END; + i := 0; + WHILE (i < p.tabs.len) + & (p.tabs.tab[i].stop = a.tabs.tab[i].stop) + & (p.tabs.tab[i].type = a.tabs.tab[i].type) DO + INC(i) + END; + IF (i = p.tabs.len) & (p.tabs.len = a.tabs.len) THEN RETURN END (* did not change *) + END + | rightToggle: + p.valid := {right, opts}; + IF ~(rightFixed IN a.opts) THEN + p.right := f.r DIV marginGrid * marginGrid + END; + p.opts.val := a.opts / {rightFixed}; p.opts.mask := {rightFixed} + | gridDec: + p.valid := {asc, grid}; g := a.grid - point; + IF g = 0 THEN p.grid := 1; p.asc := 0 ELSE p.grid := g; p.asc := g - a.dsc END + | gridVal: + SelectMark(r, f, m); RETURN + | gridInc: + p.valid := {asc, grid}; g := a.grid + point; DEC(g, g MOD point); + p.grid := g; p.asc := g - a.dsc + | leftFlush: + p.valid := {opts}; p.opts.val := {leftAdjust}; p.opts.mask := adjMask + | centered: + p.valid := {opts}; p.opts.val := {}; p.opts.mask := adjMask + | rightFlush: + p.valid := {opts}; p.opts.val := {rightAdjust}; p.opts.mask := adjMask + | justified: + p.valid := {opts}; p.opts.val := adjMask; p.opts.mask := adjMask + | leadDec: + p.valid := {lead}; p.lead := a.lead - point + | leadVal: + SelectMark(r, f, m); RETURN + | leadInc: + p.valid := {lead}; p.lead := a.lead + point + | pageBrk: + p.valid := {opts}; p.opts.val := a.opts / {pageBreak}; p.opts.mask := {pageBreak} + ELSE HALT(100) + END; + IF shift THEN ShiftDependingMarks(m, p) END; + IF m.kind IN validIcons - modeIcons THEN HiliteMark(m, f, Ports.hide) END; + + r.style.SetAttr(ModifiedAttr(a, p)) + END + END AdjustMarks; + + + (* primitivies for standard ruler *) + + PROCEDURE Track (r: StdRuler; f: Views.Frame; IN msg: Controllers.TrackMsg); + VAR m: Mark; x, y, res: INTEGER; modifiers: SET; isDown: BOOLEAN; + cmd: ARRAY 128 OF CHAR; + BEGIN + GrabMark(m, r, f, msg.x, msg.y); + REPEAT + f.Input(x, y, modifiers, isDown); TrackMark(m, f, x, y, modifiers) + UNTIL ~isDown; + AdjustMarks(m, f, modifiers); + IF Controllers.doubleClick IN msg.modifiers THEN + CASE m.kind OF + | invalid: + Dialog.MapString("#Text:OpenRulerDialog", cmd); Dialog.Call(cmd, "", res) + | gridVal, leadVal: + Dialog.MapString("#Text:OpenSizeDialog", cmd); Dialog.Call(cmd, "", res) + ELSE + END + END + END Track; + + PROCEDURE Edit (r: StdRuler; f: Views.Frame; VAR msg: Controllers.EditMsg); + VAR v: Views.View; + BEGIN + CASE msg.op OF + Controllers.copy: + msg.view := Views.CopyOf(r, Views.deep); + msg.isSingle := TRUE + | Controllers.paste: + v := msg.view; + WITH v: Ruler DO r.style.SetAttr(v.style.attr) ELSE END + ELSE + END + END Edit; + + PROCEDURE PollOps (r: StdRuler; f: Views.Frame; VAR msg: Controllers.PollOpsMsg); + BEGIN + msg.type := "TextRulers.Ruler"; + msg.pasteType := "TextRulers.Ruler"; + msg.selectable := FALSE; + msg.valid := {Controllers.copy, Controllers.paste} + END PollOps; + + PROCEDURE SetProp (r: StdRuler; VAR msg: Properties.SetMsg; VAR requestFocus: BOOLEAN); + VAR a1: Attributes; px, py, g: INTEGER; sel: INTEGER; + p: Properties.Property; sp: Properties.StdProp; rp: Prop; + BEGIN + p := msg.prop; sel := r.sel; px := r.px; py := r.py; + IF sel # invalid THEN + WHILE (p # NIL) & ~(p IS Properties.StdProp) DO p := p.next END; + IF p # NIL THEN + sp := p(Properties.StdProp); + IF (r.sel = leadVal) & (Properties.size IN sp.valid) THEN + NEW(rp); rp.valid := {lead}; + rp.lead := sp.size + ELSIF (r.sel = gridVal) & (Properties.size IN sp.valid) THEN + g := sp.size; DEC(g, g MOD point); + NEW(rp); rp.valid := {asc, grid}; + IF g = 0 THEN rp.asc := 0; rp.grid := 1 + ELSE rp.asc := g - r.style.attr.dsc; rp.grid := g + END + ELSE + rp := NIL + END + END; + p := rp + END; + a1 := ModifiedAttr(r.style.attr, p); + IF ~a1.Equals(r.style.attr) THEN + r.style.SetAttr(a1); + IF requestFocus & (r.sel = invalid) THEN (* restore mark selection *) + r.sel := sel; r.px := px; r.py := py + END + ELSE requestFocus := FALSE + END + END SetProp; + + PROCEDURE PollProp (r: StdRuler; VAR msg: Properties.PollMsg); + VAR p: Properties.StdProp; + BEGIN + CASE r.sel OF + invalid: + msg.prop := r.style.attr.Prop() + | leadVal: + NEW(p); p.known := {Properties.size}; p.valid := p.known; + p.size := r.style.attr.lead; + msg.prop := p + | gridVal: + NEW(p); p.known := {Properties.size}; p.valid := p.known; + p.size := r.style.attr.grid; + msg.prop := p + ELSE HALT(100) + END + END PollProp; + + + (* StdStyle *) + + PROCEDURE (r: StdStyle) Internalize (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + r.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdStyleVersion, thisVersion) + END Internalize; + + PROCEDURE (r: StdStyle) Externalize (VAR wr: Stores.Writer); + BEGIN + r.Externalize^(wr); + wr.WriteVersion(maxStdStyleVersion) + END Externalize; +(* + PROCEDURE (r: StdStyle) CopyFrom (source: Stores.Store); + BEGIN + r.SetAttr(source(StdStyle).attr) + END CopyFrom; +*) + + (* StdRuler *) + + PROCEDURE (r: StdRuler) Internalize (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + r.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdRulerVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + r.sel := invalid + END Internalize; + + PROCEDURE (r: StdRuler) Externalize (VAR wr: Stores.Writer); + BEGIN + r.Externalize^(wr); + wr.WriteVersion(maxStdRulerVersion) + END Externalize; + + PROCEDURE (r: StdRuler) ThisModel (): Models.Model; + BEGIN + RETURN r.style + END ThisModel; + + PROCEDURE (r: StdRuler) CopyFromModelView (source: Views.View; model: Models.Model); + BEGIN + r.sel := invalid; r.InitStyle(model(Style)) + END CopyFromModelView; + + PROCEDURE (ruler: StdRuler) Restore (f: Views.Frame; l, t, r, b: INTEGER); + VAR a: Attributes; m: Mark; u, scale, tabBar, px, w, h: INTEGER; i: INTEGER; + BEGIN + u := f.dot; a := ruler.style.attr; + ruler.context.GetSize(w, h); + tabBar := h - tabBarHeight; scale := tabBar - scaleHeight; + w := MIN(f.r + 10 * mm, 10000 * mm); (* high-level clipping *) + f.DrawLine(0, scale - u, w - u, scale - u, u, Ports.grey25); + f.DrawLine(0, tabBar - u, w - u, tabBar - u, u, Ports.grey50); + DrawScale(f, 0, scale, w, tabBar, l, r); + DrawNiceRect(f, 0, h - rulerHeight, w, h); + SetMark(m, ruler, a.first, h, first, -1); InvertMark(m, f, Ports.show); + SetMark(m, ruler, a.left, h, left, -1); InvertMark(m, f, Ports.show); + IF rightFixed IN a.opts THEN + SetMark(m, ruler, a.right, h, right, -1); InvertMark(m, f, Ports.show) + END; + i := 0; + WHILE i < a.tabs.len DO + SetMark(m, ruler, a.tabs.tab[i].stop, h, tabs, i); InvertMark(m, f, Ports.show); INC(i) + END; + px := iconGap; i := firstIcon; + WHILE i <= lastIcon DO + IF i IN validIcons THEN + SetMark(m, ruler, px, h - iconPin, i, -1); DrawMark(m, f) + END; + INC(px, iconWidth + iconGap); INC(i) + END; + HiliteThisMark(ruler, f, Mode(ruler), Ports.show) + END Restore; + + PROCEDURE (ruler: StdRuler) RestoreMarks (f: Views.Frame; l, t, r, b: INTEGER); + BEGIN + HiliteThisMark(ruler, f, ruler.sel, Ports.show) + END RestoreMarks; + + PROCEDURE (r: StdRuler) GetBackground (VAR color: Ports.Color); + BEGIN + color := Ports.background + END GetBackground; + + PROCEDURE (r: StdRuler) Neutralize; + VAR msg: NeutralizeMsg; + BEGIN + Views.Broadcast(r, msg) + END Neutralize; + + PROCEDURE (r: StdRuler) HandleModelMsg (VAR msg: Models.Message); + BEGIN + WITH msg: UpdateMsg DO + Views.Update(r, Views.keepFrames) + ELSE + END + END HandleModelMsg; + + PROCEDURE (r: StdRuler) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message); + BEGIN + WITH msg: NeutralizeMsg DO + DeselectMark(r, f) + ELSE + END + END HandleViewMsg; + + PROCEDURE (r: StdRuler) HandleCtrlMsg (f: Views.Frame; + VAR msg: Controllers.Message; VAR focus: Views.View + ); + VAR requestFocus: BOOLEAN; + BEGIN + WITH msg: Controllers.TrackMsg DO + Track(r, f, msg) + | msg: Controllers.EditMsg DO + Edit(r, f, msg) + | msg: Controllers.MarkMsg DO + r.RestoreMarks(f, f.l, f.t, f.r, f.b) + | msg: Controllers.SelectMsg DO + IF ~msg.set THEN DeselectMark(r, f) END + | msg: Controllers.PollOpsMsg DO + PollOps(r, f, msg) + | msg: Properties.CollectMsg DO + PollProp(r, msg.poll) + | msg: Properties.EmitMsg DO + requestFocus := f.front; + SetProp(r, msg.set, requestFocus); + msg.requestFocus := requestFocus + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (r: StdRuler) HandlePropMsg (VAR msg: Properties.Message); + VAR m: Mark; requestFocus: BOOLEAN; w, h: INTEGER; + BEGIN + WITH msg: Properties.SizePref DO + msg.w := 10000 * Ports.mm; msg.h := rulerHeight + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + IF msg.atLocation THEN + r.context.GetSize(w, h); + GetMark(m, r, NIL, msg.x, msg.y, FALSE); + msg.hotFocus := (m.kind # invalid) & ~(m.kind IN fieldIcons) OR (msg.y >= h - tabBarHeight); + msg.setFocus := ~msg.hotFocus + END + | msg: TextModels.Pref DO + msg.opts := {TextModels.maskChar, TextModels.hideable}; + msg.mask := TextModels.para + | msg: Properties.SetMsg DO + requestFocus := FALSE; + SetProp(r, msg, requestFocus) + | msg: Properties.PollMsg DO + PollProp(r, msg) + ELSE + END + END HandlePropMsg; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) NewStyle (attr: Attributes): Style; + VAR s: StdStyle; + BEGIN + IF attr = NIL THEN attr := d.attr END; + NEW(s); s.SetAttr(attr); RETURN s + END NewStyle; + + PROCEDURE (d: StdDirectory) New (style: Style): Ruler; + VAR r: StdRuler; + BEGIN + IF style = NIL THEN style := d.NewStyle(NIL) END; + NEW(r); r.InitStyle(style); r.sel := invalid; RETURN r + END New; + + + (** miscellaneous **) + + PROCEDURE GetValidRuler* (text: TextModels.Model; pos, hint: INTEGER; + VAR ruler: Ruler; VAR rpos: INTEGER + ); + (** pre: (hint < 0 OR (ruler, rpos) is first ruler before hint & 0 <= pos <= t.Length() **) + (** post: hint < rpos <= pos & rpos = Pos(ruler) & (no ruler in (rpos, pos]) + OR ((ruler, rpos) unmodified) + **) + VAR view: Views.View; + BEGIN + IF pos < text.Length() THEN INC(pos) END; (* let a ruler dominate its own position *) + IF pos < hint THEN hint := -1 END; + globRd := text.NewReader(globRd); globRd.SetPos(pos); + REPEAT + globRd.ReadPrevView(view) + UNTIL globRd.eot OR (view IS Ruler) OR (globRd.Pos() < hint); + IF (view # NIL) & (view IS Ruler) THEN + ruler := view(Ruler); rpos := globRd.Pos() + END + END GetValidRuler; + + PROCEDURE SetDir* (d: Directory); + (** pre: d # NIL, d.attr # NIL **) + (** post: dir = d **) + BEGIN + ASSERT(d # NIL, 20); ASSERT(d.attr.init, 21); dir := d + END SetDir; + + + PROCEDURE Init; + VAR d: StdDirectory; fnt: Fonts.Font; asc, dsc, w: INTEGER; + BEGIN + IF Dialog.metricSystem THEN + marginGrid := 1*mm; minTabWidth := 1*mm; tabGrid := 1*mm + ELSE + marginGrid := inch16; minTabWidth := inch16; tabGrid := inch16 + END; + + fnt := Fonts.dir.Default(); + font := Fonts.dir.This(fnt.typeface, 7*point, {}, Fonts.normal); (* font for ruler scales *) + NEW(prop); + prop.valid := {first .. tabs}; + prop.first := 0; prop.left := 0; + IF Dialog.metricSystem THEN + prop.right := 165*mm + ELSE + prop.right := 104*inch16 + END; + fnt.GetBounds(asc, dsc, w); + prop.lead := 0; prop.asc := asc; prop.dsc := dsc; prop.grid := 1; + prop.opts.val := {leftAdjust}; prop.opts.mask := options; + prop.tabs.len := 0; + + NEW(def); def.InitFromProp(prop); + NEW(d); d.attr := def; dir := d; stdDir := d + END Init; + + PROCEDURE Cleaner; + BEGIN + globRd := NIL + END Cleaner; + +BEGIN + Init; + Kernel.InstallCleaner(Cleaner) +CLOSE + Kernel.RemoveCleaner(Cleaner) +END TextRulers. diff --git a/Trurl-based/Text/Mod/Setters.odc b/Trurl-based/Text/Mod/Setters.odc new file mode 100644 index 0000000..8dd7766 Binary files /dev/null and b/Trurl-based/Text/Mod/Setters.odc differ diff --git a/Trurl-based/Text/Mod/Setters.txt b/Trurl-based/Text/Mod/Setters.txt new file mode 100644 index 0000000..77aab8b --- /dev/null +++ b/Trurl-based/Text/Mod/Setters.txt @@ -0,0 +1,1313 @@ +MODULE TextSetters; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Setters.odc *) + (* DO NOT EDIT *) + + (* correct NextPage postcond in docu *) + (* make s.r, s.rd reducible? *) + (* paraShutoff needs to be controlled by an approx flag to certain ops (later ...?) *) + + IMPORT + Fonts, Ports, Printers, Stores, Models, Views, Properties, + TextModels, TextRulers; + + CONST + (** Pref.opts, options of setter-aware views; 0 overrides 1 **) + lineBreak* = 0; wordJoin* = 1; wordPart* = 2; flexWidth* = 3; + + tab = TextModels.tab; line = TextModels.line; para = TextModels.para; + zwspace = TextModels.zwspace; nbspace = TextModels.nbspace; + hyphen = TextModels.hyphen; nbhyphen = TextModels.nbhyphen; + digitspace = TextModels.digitspace; + softhyphen = TextModels.softhyphen; + + mm = Ports.mm; + minTabWidth = 2 * Ports.point; stdTabWidth = 4 * mm; + leftLineGap = 2 * Ports.point; rightLineGap = 3 * Ports.point; + adjustMask = {TextRulers.leftAdjust, TextRulers.rightAdjust}; + centered = {}; leftFlush = {TextRulers.leftAdjust}; rightFlush = {TextRulers.rightAdjust}; + blocked = adjustMask; + + boxCacheLen = 64; + seqCacheLen = 16; + + paraShutoff = MAX(INTEGER); (* longest stretch read backwards to find start of paragraph *) + (* unsafe: disabled *) + cachedRulers = FALSE; (* caching ruler objects trades speed against GC effectiveness *) + periodInWords = FALSE; + colonInWords = FALSE; + + minVersion = 0; maxVersion = 0; maxStdVersion = 0; + + + TYPE + Pref* = RECORD (Properties.Preference) + opts*: SET; + endW*: INTEGER; (** preset (to width of view) **) + dsc*: INTEGER (** preset (to dominating line descender) **) + END; + + + Reader* = POINTER TO ABSTRACT RECORD + r-: TextModels.Reader; (** look-ahead state **) + (** unit **) + string*: ARRAY 64 OF CHAR; (** single chars in string[0] **) + view*: Views.View; + (** unit props **) + textOpts*: SET; + mask*: CHAR; + setterOpts*: SET; + w*, endW*, h*, dsc*: INTEGER; + attr*: TextModels.Attributes; + (** reading state **) + eot*: BOOLEAN; + pos*: INTEGER; + x*: INTEGER; (** to be advanced by client! **) + adjStart*: INTEGER; + spaces*: INTEGER; + tabIndex*: INTEGER; (** tabs being processed; initially -1 **) + tabType*: SET; (** type of tab being processed; initially {} **) + (** line props **) + vw*: INTEGER; + hideMarks*: BOOLEAN; + ruler*: TextRulers.Ruler; + rpos*: INTEGER + END; + + Setter* = POINTER TO ABSTRACT RECORD (Stores.Store) + text-: TextModels.Model; (** connected iff text # NIL **) + defRuler-: TextRulers.Ruler; + vw-: INTEGER; + hideMarks-: BOOLEAN + END; + + + LineBox* = RECORD + len*: INTEGER; + ruler*: TextRulers.Ruler; + rpos*: INTEGER; + left*, right*, asc*, dsc*: INTEGER; + rbox*, bop*, adj*, eot*: BOOLEAN; (** adj => adjW > 0; adj & blocked => spaces > 0 **) + views*: BOOLEAN; + skipOff*: INTEGER; (** chars in [skipOff, len) take endW **) + adjOff*: INTEGER; (** offset of last block in box - adjust only this block **) + spaces*: INTEGER; (** valid, > 0 if adj & blocked **) + adjW*: INTEGER; (** valid if adj - to be distributed over spaces **) + tabW*: ARRAY TextRulers.maxTabs OF INTEGER (** delta width of tabs (<= 0) **) + END; + + + Directory* = POINTER TO ABSTRACT RECORD END; + + + Worder = RECORD + box: LineBox; next: INTEGER; + i: INTEGER + END; + + StdReader = POINTER TO RECORD (Reader) END; + + StdSetter = POINTER TO RECORD (Setter) + rd: Reader; (* subject to reduction? *) + r: TextModels.Reader; (* subject to reduction? *) + ruler: TextRulers.Ruler; + rpos: INTEGER; + key: INTEGER + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + + VAR + dir-, stdDir-: Directory; + + nextKey: INTEGER; + boxIndex, seqIndex: INTEGER; + boxCache: ARRAY boxCacheLen OF RECORD + key: INTEGER; (* valid iff key > 0 *) + start: INTEGER; + line: LineBox (* inv ruler = NIL *) + END; + seqCache: ARRAY seqCacheLen OF RECORD + key: INTEGER; (* valid iff key > 0 *) + start, pos: INTEGER (* sequence [start, end), end >= pos *) + END; + + + (** Reader **) + + PROCEDURE (rd: Reader) Set* ( + old: TextModels.Reader; + text: TextModels.Model; x, pos: INTEGER; + ruler: TextRulers.Ruler; rpos: INTEGER; vw: INTEGER; hideMarks: BOOLEAN + ), NEW, EXTENSIBLE; + BEGIN + ASSERT(text # NIL, 20); + ASSERT(ruler # NIL, 22); + rd.r := text.NewReader(old); rd.r.SetPos(pos); rd.r.Read; + rd.string[0] := 0X; rd.view := NIL; + rd.textOpts := {}; + rd.setterOpts := {}; rd.w := 0; rd.endW := 0; rd.h := 0; rd.dsc := 0; + rd.attr := NIL; + rd.eot := FALSE; rd.pos := pos; rd.x := x; + rd.tabIndex := -1; rd.tabType := {}; + rd.adjStart := pos; rd.spaces := 0; + rd.ruler := ruler; rd.rpos := rpos; rd.vw := vw; rd.hideMarks := hideMarks + END Set; + + PROCEDURE (rd: Reader) Read*, NEW, EXTENSIBLE; + (** pre: rd set **) + (** post: rd.pos = rd.pos' + Length(rd.string) **) + BEGIN + rd.string[0] := rd.r.char; rd.string[1] := 0X; + rd.view := rd.r.view; + rd.textOpts := {}; + rd.setterOpts := {}; + rd.w := rd.r.w; rd.endW := rd.w; rd.h := rd.r.h; rd.dsc := 0; + rd.attr := rd.r.attr; + rd.eot := rd.r.eot; + INC(rd.pos); + rd.r.Read + END Read; + + PROCEDURE (rd: Reader) AdjustWidth* (start, pos: INTEGER; IN box: LineBox; + VAR w: INTEGER + ), NEW, ABSTRACT; + + PROCEDURE (rd: Reader) SplitWidth* (w: INTEGER): INTEGER, NEW, ABSTRACT; + + + (** Setter **) + + PROCEDURE (s: Setter) CopyFrom- (source: Stores.Store), EXTENSIBLE; + BEGIN + WITH source: Setter DO + s.text := source.text; s.defRuler := source.defRuler; + s.vw := source.vw; s.hideMarks := source.hideMarks + END + END CopyFrom; + + PROCEDURE (s: Setter) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion: INTEGER; + BEGIN + s.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion) + END Internalize; + + PROCEDURE (s: Setter) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + s.Externalize^(wr); + wr.WriteVersion(maxVersion) + END Externalize; + + PROCEDURE (s: Setter) ConnectTo* (text: TextModels.Model; + defRuler: TextRulers.Ruler; vw: INTEGER; hideMarks: BOOLEAN + ), NEW, EXTENSIBLE; + BEGIN + IF text # NIL THEN + s.text := text; s.defRuler := defRuler; s.vw := vw; s.hideMarks := hideMarks + ELSE + s.text := NIL; s.defRuler := NIL + END + END ConnectTo; + + + PROCEDURE (s: Setter) ThisPage* (pageH: INTEGER; pageNo: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, 0 <= pageNo **) + (** post: (result = -1) & (pageNo >= maxPageNo) OR (result = pageStart(pageNo)) **) + + PROCEDURE (s: Setter) NextPage* (pageH: INTEGER; start: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, ThisPage(pageH, pageNo) = start [with pageNo = NumberOfPageAt(start)] **) + (** post: (result = start) & last-page(start) OR result = next-pageStart(start) **) + + + PROCEDURE (s: Setter) ThisSequence* (pos: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, 0 <= pos <= s.text.Length() **) + (** post: (result = 0) OR (char(result - 1) IN {line, para}) **) + + PROCEDURE (s: Setter) NextSequence* (start: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, ThisSequence(start) = start **) + (** post: (result = start) & last-line(start) OR (ThisSequence(t, result - 1) = start) **) + + PROCEDURE (s: Setter) PreviousSequence* (start: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, ThisSequence(t, start) = start **) + (** post: (result = 0) & (start = 0) OR (result = ThisSequence(t, start - 1)) **) + + + PROCEDURE (s: Setter) ThisLine* (pos: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, 0 <= pos <= s.text.Length() **) + (** post: result <= pos, (pos < NextLine(result)) OR last-line(result) **) + + PROCEDURE (s: Setter) NextLine* (start: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, ThisLine(start) = start **) + (** post: (result = 0) & (start = 0) OR + (result = start) & last-line(start) OR + (ThisLine(result - 1) = start) **) + + PROCEDURE (s: Setter) PreviousLine* (start: INTEGER): INTEGER, NEW, ABSTRACT; + (** pre: connected, ThisLine(start) = start **) + (** post: (result = 0) & (start = 0) OR (result = ThisLine(start - 1)) **) + + + PROCEDURE (s: Setter) GetWord* (pos: INTEGER; OUT beg, end: INTEGER), NEW, ABSTRACT; + (** pre: connected, 0 <= pos <= s.text.Length() **) + (** post: c set, beg <= pos <= end **) + + PROCEDURE (s: Setter) GetLine* (start: INTEGER; OUT box: LineBox), NEW, ABSTRACT; + (** pre: connected, ThisLine(start) = start, 0 <= start <= s.text.Length() **) + (** post: (c, box) set (=> box.ruler # NIL), (box.len > 0) OR box.eot, + 0 <= box.left <= box.right <= ruler.right **) + + PROCEDURE (s: Setter) GetBox* (start, end, maxW, maxH: INTEGER; + OUT w, h: INTEGER + ), NEW, ABSTRACT; + (** pre: connected, ThisLine(start) = start, 0 <= start <= end <= s.text.Length() **) + (** post: c set, maxW > undefined => w <= maxW, maxH > undefined => h <= maxH **) + + + PROCEDURE (s: Setter) NewReader* (old: Reader): Reader, NEW, ABSTRACT; + (** pre: connected **) + + + PROCEDURE (s: Setter) GridOffset* (dsc: INTEGER; IN box: LineBox): INTEGER, NEW, ABSTRACT; + (** pre: connected, dsc >= 0: dsc is descender of previous line; dsc = -1 for first line **) + (** post: dsc + GridOffset(dsc, box) + box.asc = k*ruler.grid (k >= 0) >= ruler.asc + ruler.grid **) + + + (** Directory **) + + PROCEDURE (d: Directory) New* (): Setter, NEW, ABSTRACT; + + + (* line box cache *) + + PROCEDURE InitCache; + VAR i: INTEGER; + BEGIN + nextKey := 1; boxIndex := 0; seqIndex := 0; + i := 0; WHILE i < boxCacheLen DO boxCache[i].key := -1; INC(i) END; + i := 0; WHILE i < seqCacheLen DO seqCache[i].key := -1; INC(i) END + END InitCache; + + PROCEDURE ClearCache (key: INTEGER); + VAR i, j: INTEGER; + BEGIN + i := 0; j := boxIndex; + WHILE i < boxCacheLen DO + IF boxCache[i].key = key THEN boxCache[i].key := -1; j := i END; + INC(i) + END; + boxIndex := j; + i := 0; j := seqIndex; + WHILE i < seqCacheLen DO + IF seqCache[i].key = key THEN seqCache[i].key := -1; j := i END; + INC(i) + END; + seqIndex := j + END ClearCache; + + + PROCEDURE CacheIndex (key, start: INTEGER): INTEGER; + VAR i: INTEGER; + BEGIN +RETURN -1; + i := 0; + WHILE (i < boxCacheLen) & ~((boxCache[i].key = key) & (boxCache[i].start = start)) DO + INC(i) + END; + IF i = boxCacheLen THEN i := -1 END; + RETURN i + END CacheIndex; + + PROCEDURE GetFromCache (s: StdSetter; i: INTEGER; VAR l: LineBox); + BEGIN + l := boxCache[i].line; + IF ~cachedRulers THEN + IF l.rpos >= 0 THEN + s.r := s.text.NewReader(s.r); s.r.SetPos(l.rpos); s.r.Read; + l.ruler := s.r.view(TextRulers.Ruler) + ELSE l.ruler := s.defRuler + END + END + END GetFromCache; + + PROCEDURE AddToCache (key, start: INTEGER; VAR l: LineBox); + VAR i: INTEGER; + BEGIN + i := boxIndex; boxIndex := (i + 1) MOD boxCacheLen; + boxCache[i].key := key; boxCache[i].start := start; boxCache[i].line := l; + IF ~cachedRulers THEN + boxCache[i].line.ruler := NIL + END + END AddToCache; + + + PROCEDURE CachedSeqStart (key, pos: INTEGER): INTEGER; + VAR start: INTEGER; i: INTEGER; + BEGIN + i := 0; + WHILE (i < seqCacheLen) + & ~((seqCache[i].key = key) & (seqCache[i].start <= pos) & (pos <= seqCache[i].pos)) DO + INC(i) + END; + IF i < seqCacheLen THEN start := seqCache[i].start ELSE start := -1 END; + RETURN start + END CachedSeqStart; + + PROCEDURE AddSeqStartToCache (key, pos, start: INTEGER); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (i < seqCacheLen) & ~((seqCache[i].key = key) & (seqCache[i].start = start)) DO + INC(i) + END; + IF i < seqCacheLen THEN + IF seqCache[i].pos < pos THEN seqCache[i].pos := pos END + ELSE + i := seqIndex; seqIndex := (i + 1) MOD seqCacheLen; + seqCache[i].key := key; seqCache[i].pos := pos; seqCache[i].start := start + END + END AddSeqStartToCache; + + + (* StdReader *) + +(* + PROCEDURE WordPart (ch, ch1: CHAR): BOOLEAN; + (* needs more work ... put elsewhere? *) + BEGIN + CASE ORD(ch) OF + ORD("0") .. ORD("9"), ORD("A") .. ORD("Z"), ORD("a") .. ORD("z"), + ORD(digitspace), ORD(nbspace), ORD(nbhyphen), ORD("_"), + 0C0H .. 0C6H, 0E0H .. 0E6H, (* ~ A *) + 0C7H, 0E7H, (* ~ C *) + 0C8H .. 0CBH, 0E8H .. 0EBH, (* ~ E *) + 0CCH .. 0CFH, 0ECH .. 0EFH, (* ~ I *) + 0D1H, 0F1H, (* ~ N *) + 0D2H .. 0D6H, 0D8H, 0F2H .. 0F6H, 0F8H, (* ~ O *) + 0D9H .. 0DCH, 0F9H .. 0FCH, (* ~ U *) + 0DDH, 0FDH, 0FFH, (* ~ Y *) + 0DFH: (* ~ ss *) + RETURN TRUE + | ORD("."), ORD(":"): + IF (ch = ".") & periodInWords OR (ch = ":") & colonInWords THEN + CASE ch1 OF + 0X, TextModels.viewcode, tab, line, para, " ": + RETURN FALSE + ELSE RETURN TRUE + END + ELSE RETURN FALSE + END + ELSE RETURN FALSE + END + END WordPart; +*) + + PROCEDURE WordPart (ch, ch1: CHAR): BOOLEAN; + (* Same as .net function System.Char.IsLetterOrDigit(ch) + + digit space, nonbreaking space, nonbreaking hyphen, & underscore + ch1 unused *) + VAR low: INTEGER; + BEGIN + low := ORD(ch) MOD 256; + CASE ORD(ch) DIV 256 OF + | 001H, 015H, 034H..04CH, 04EH..09EH, 0A0H..0A3H, 0ACH..0D6H, 0F9H, 0FCH: RETURN TRUE + | 000H: CASE low OF + | 030H..039H, 041H..05AH, 061H..07AH, 0AAH, 0B5H, 0BAH, 0C0H..0D6H, 0D8H..0F6H, 0F8H..0FFH, + ORD(digitspace), ORD(nbspace), ORD(nbhyphen), ORD("_"): RETURN TRUE + ELSE + END + | 002H: CASE low OF + | 000H..041H, 050H..0C1H, 0C6H..0D1H, 0E0H..0E4H, 0EEH: RETURN TRUE + ELSE + END + | 003H: CASE low OF + | 07AH, 086H, 088H..08AH, 08CH, 08EH..0A1H, 0A3H..0CEH, 0D0H..0F5H, 0F7H..0FFH: RETURN TRUE + ELSE + END + | 004H: CASE low OF + | 000H..081H, 08AH..0CEH, 0D0H..0F9H: RETURN TRUE + ELSE + END + | 005H: CASE low OF + | 000H..00FH, 031H..056H, 059H, 061H..087H, 0D0H..0EAH, 0F0H..0F2H: RETURN TRUE + ELSE + END + | 006H: CASE low OF + | 021H..03AH, 040H..04AH, 060H..069H, 06EH..06FH, 071H..0D3H, 0D5H, 0E5H..0E6H, 0EEH..0FCH, 0FFH: RETURN TRUE + ELSE + END + | 007H: CASE low OF + | 010H, 012H..02FH, 04DH..06DH, 080H..0A5H, 0B1H: RETURN TRUE + ELSE + END + | 009H: CASE low OF + | 004H..039H, 03DH, 050H, 058H..061H, 066H..06FH, 07DH, 085H..08CH, 08FH..090H, 093H..0A8H, 0AAH..0B0H, 0B2H, 0B6H..0B9H, 0BDH, 0CEH, 0DCH..0DDH, 0DFH..0E1H, 0E6H..0F1H: RETURN TRUE + ELSE + END + | 00AH: CASE low OF + | 005H..00AH, 00FH..010H, 013H..028H, 02AH..030H, 032H..033H, 035H..036H, 038H..039H, 059H..05CH, 05EH, 066H..06FH, 072H..074H, 085H..08DH, 08FH..091H, 093H..0A8H, 0AAH..0B0H, 0B2H..0B3H, 0B5H..0B9H, 0BDH, 0D0H, 0E0H..0E1H, 0E6H..0EFH: RETURN TRUE + ELSE + END + | 00BH: CASE low OF + | 005H..00CH, 00FH..010H, 013H..028H, 02AH..030H, 032H..033H, 035H..039H, 03DH, 05CH..05DH, 05FH..061H, 066H..06FH, 071H, 083H, 085H..08AH, 08EH..090H, 092H..095H, 099H..09AH, 09CH, 09EH..09FH, 0A3H..0A4H, 0A8H..0AAH, 0AEH..0B9H, 0E6H..0EFH: RETURN TRUE + ELSE + END + | 00CH: CASE low OF + | 005H..00CH, 00EH..010H, 012H..028H, 02AH..033H, 035H..039H, 060H..061H, 066H..06FH, 085H..08CH, 08EH..090H, 092H..0A8H, 0AAH..0B3H, 0B5H..0B9H, 0BDH, 0DEH, 0E0H..0E1H, 0E6H..0EFH: RETURN TRUE + ELSE + END + | 00DH: CASE low OF + | 005H..00CH, 00EH..010H, 012H..028H, 02AH..039H, 060H..061H, 066H..06FH, 085H..096H, 09AH..0B1H, 0B3H..0BBH, 0BDH, 0C0H..0C6H: RETURN TRUE + ELSE + END + | 00EH: CASE low OF + | 001H..030H, 032H..033H, 040H..046H, 050H..059H, 081H..082H, 084H, 087H..088H, 08AH, 08DH, 094H..097H, 099H..09FH, 0A1H..0A3H, 0A5H, 0A7H, 0AAH..0ABH, 0ADH..0B0H, 0B2H..0B3H, 0BDH, 0C0H..0C4H, 0C6H, 0D0H..0D9H, 0DCH..0DDH: RETURN TRUE + ELSE + END + | 00FH: CASE low OF + | 000H, 020H..029H, 040H..047H, 049H..06AH, 088H..08BH: RETURN TRUE + ELSE + END + | 010H: CASE low OF + | 000H..021H, 023H..027H, 029H..02AH, 040H..049H, 050H..055H, 0A0H..0C5H, 0D0H..0FAH, 0FCH: RETURN TRUE + ELSE + END + | 011H: CASE low OF + | 000H..059H, 05FH..0A2H, 0A8H..0F9H: RETURN TRUE + ELSE + END + | 012H: CASE low OF + | 000H..048H, 04AH..04DH, 050H..056H, 058H, 05AH..05DH, 060H..088H, 08AH..08DH, 090H..0B0H, 0B2H..0B5H, 0B8H..0BEH, 0C0H, 0C2H..0C5H, 0C8H..0D6H, 0D8H..0FFH: RETURN TRUE + ELSE + END + | 013H: CASE low OF + | 000H..010H, 012H..015H, 018H..05AH, 080H..08FH, 0A0H..0F4H: RETURN TRUE + ELSE + END + | 014H: IF low >= 001H THEN RETURN TRUE END + | 016H: CASE low OF + | 000H..06CH, 06FH..076H, 081H..09AH, 0A0H..0EAH: RETURN TRUE + ELSE + END + | 017H: CASE low OF + | 000H..00CH, 00EH..011H, 020H..031H, 040H..051H, 060H..06CH, 06EH..070H, 080H..0B3H, 0D7H, 0DCH, 0E0H..0E9H: RETURN TRUE + ELSE + END + | 018H: CASE low OF + | 010H..019H, 020H..077H, 080H..0A8H: RETURN TRUE + ELSE + END + | 019H: CASE low OF + | 000H..01CH, 046H..06DH, 070H..074H, 080H..0A9H, 0C1H..0C7H, 0D0H..0D9H: RETURN TRUE + ELSE + END + | 01AH: IF low < 017H THEN RETURN TRUE END + | 01DH: IF low < 0C0H THEN RETURN TRUE END + | 01EH: CASE low OF + | 000H..09BH, 0A0H..0F9H: RETURN TRUE + ELSE + END + | 01FH: CASE low OF + | 000H..015H, 018H..01DH, 020H..045H, 048H..04DH, 050H..057H, 059H, 05BH, 05DH, 05FH..07DH, 080H..0B4H, 0B6H..0BCH, 0BEH, 0C2H..0C4H, 0C6H..0CCH, 0D0H..0D3H, 0D6H..0DBH, 0E0H..0ECH, 0F2H..0F4H, 0F6H..0FCH: RETURN TRUE + ELSE + END + | 020H: CASE low OF + | 071H, 07FH, 090H..094H: RETURN TRUE + ELSE + END + | 021H: CASE low OF + | 002H, 007H, 00AH..013H, 015H, 019H..01DH, 024H, 026H, 028H, 02AH..02DH, 02FH..031H, 033H..039H, 03CH..03FH, 045H..049H: RETURN TRUE + ELSE + END + | 02CH: CASE low OF + | 000H..02EH, 030H..05EH, 080H..0E4H: RETURN TRUE + ELSE + END + | 02DH: CASE low OF + | 000H..025H, 030H..065H, 06FH, 080H..096H, 0A0H..0A6H, 0A8H..0AEH, 0B0H..0B6H, 0B8H..0BEH, 0C0H..0C6H, 0C8H..0CEH, 0D0H..0D6H, 0D8H..0DEH: RETURN TRUE + ELSE + END + | 030H: CASE low OF + | 005H..006H, 031H..035H, 03BH..03CH, 041H..096H, 09DH..09FH, 0A1H..0FAH, 0FCH..0FFH: RETURN TRUE + ELSE + END + | 031H: CASE low OF + | 005H..02CH, 031H..08EH, 0A0H..0B7H, 0F0H..0FFH: RETURN TRUE + ELSE + END + | 04DH: IF low < 0B6H THEN RETURN TRUE END + | 09FH: IF low < 0BCH THEN RETURN TRUE END + | 0A4H: IF low < 08DH THEN RETURN TRUE END + | 0A8H: CASE low OF + | 000H..001H, 003H..005H, 007H..00AH, 00CH..022H: RETURN TRUE + ELSE + END + | 0D7H: IF low < 0A4H THEN RETURN TRUE END + | 0FAH: CASE low OF + | 000H..02DH, 030H..06AH, 070H..0D9H: RETURN TRUE + ELSE + END + | 0FBH: CASE low OF + | 000H..006H, 013H..017H, 01DH, 01FH..028H, 02AH..036H, 038H..03CH, 03EH, 040H..041H, 043H..044H, 046H..0B1H, 0D3H..0FFH: RETURN TRUE + ELSE + END + | 0FDH: CASE low OF + | 000H..03DH, 050H..08FH, 092H..0C7H, 0F0H..0FBH: RETURN TRUE + ELSE + END + | 0FEH: CASE low OF + | 070H..074H, 076H..0FCH: RETURN TRUE + ELSE + END + | 0FFH: CASE low OF + | 010H..019H, 021H..03AH, 041H..05AH, 066H..0BEH, 0C2H..0C7H, 0CAH..0CFH, 0D2H..0D7H, 0DAH..0DCH: RETURN TRUE + ELSE + END + ELSE + END; + RETURN FALSE + END WordPart; + +(* + PROCEDURE ExtendToEOL (x, right: INTEGER): INTEGER; + BEGIN + IF right - x > 5 * mm THEN RETURN right - x ELSE RETURN 5 * mm END + END ExtendToEOL; +*) + + PROCEDURE Right (ra: TextRulers.Attributes; vw: INTEGER): INTEGER; + BEGIN + IF TextRulers.rightFixed IN ra.opts THEN + RETURN ra.right + ELSE + RETURN vw + END + END Right; + + PROCEDURE GetViewPref (rd: StdReader); + CONST maxH = 1600 * Ports.point; + VAR ra: TextRulers.Attributes; tp: TextModels.Pref; sp: Pref; + BEGIN + ra := rd.ruler.style.attr; + tp.opts := {}; Views.HandlePropMsg(rd.view, tp); + rd.textOpts := tp.opts; rd.mask := tp.mask; + sp.opts := {}; sp.dsc := ra.dsc; sp.endW := rd.w; Views.HandlePropMsg(rd.view, sp); + rd.setterOpts := sp.opts; rd.dsc := sp.dsc; rd.endW := sp.endW; + IF rd.w >= 10000 * mm THEN rd.w := 10000 * mm END; + IF (TextModels.hideable IN tp.opts) & rd.hideMarks THEN + rd.h := 0; sp.dsc := 0; +(* +rd.w := 0; +*) + IF ~( (rd.view IS TextRulers.Ruler) + OR (TextModels.maskChar IN rd.textOpts) & (rd.mask = para) ) THEN + rd.w := 0 + END +(**) + ELSIF rd.h > maxH THEN rd.h := maxH + END; + IF TextModels.maskChar IN rd.textOpts THEN + rd.string[0] := rd.mask; rd.string[1] := 0X + ELSE rd.string[0] := TextModels.viewcode + END + END GetViewPref; + + PROCEDURE GatherString (rd: StdReader); + VAR i, len: INTEGER; ch: CHAR; + BEGIN + i := 1; len := LEN(rd.string) - 1; ch := rd.r.char; + WHILE (i < len) + & (rd.r.view = NIL) & (rd.r.attr = rd.attr) + & ( (" " < ch) & (ch <= "~") & (ch # "-") + OR (ch = digitspace) + OR (ch >= nbspace) & (ch < 100X) & (ch # softhyphen) + ) + DO (* rd.r.char > " " => ~rd.eot *) + rd.string[i] := ch; INC(i); + rd.eot := rd.r.eot; + rd.r.Read; ch := rd.r.char; INC(rd.pos) + END; + rd.string[i] := 0X; rd.setterOpts := {wordJoin}; + IF i = 1 THEN + IF WordPart(rd.string[0], 0X) THEN INCL(rd.setterOpts, wordPart) END + END; + rd.w := rd.attr.font.StringWidth(rd.string); rd.endW := rd.w + END GatherString; + + PROCEDURE SpecialChar (rd: StdReader); + VAR ra: TextRulers.Attributes; i, tabs, spaceW, dW: INTEGER; type: SET; + BEGIN + ra := rd.ruler.style.attr; + CASE ORD(rd.string[0]) OF + ORD(tab): + rd.textOpts := {TextModels.hideable}; + rd.endW := minTabWidth; + rd.adjStart := rd.pos; rd.spaces := 0; + (* + i := 0; WHILE (i < ra.tabs.len) & (ra.tabs.tab[i].stop < rd.x + minTabWidth) DO INC(i) END; + *) + i := rd.tabIndex + 1; + IF i < ra.tabs.len THEN + type := ra.tabs.tab[i].type; + rd.w := MAX(minTabWidth, ra.tabs.tab[i].stop - rd.x); + IF TextRulers.barTab IN type THEN + IF TextRulers.rightTab IN type THEN + rd.w := MAX(minTabWidth, rd.w - leftLineGap) + ELSIF ~(TextRulers.centerTab IN type) THEN + INC(rd.w, rightLineGap) + END + END; + rd.tabIndex := i; rd.tabType := type + ELSE (* for "reasonable" fonts: round to closest multiple of spaces of this font *) + spaceW := rd.attr.font.SStringWidth(" "); + IF (1 <= spaceW) & (spaceW <= stdTabWidth) THEN + rd.w := (stdTabWidth + spaceW DIV 2) DIV spaceW * spaceW + ELSE + rd.w := stdTabWidth + END; + rd.tabIndex := TextRulers.maxTabs; rd.tabType := {} + END + | ORD(line): + rd.setterOpts := {lineBreak}; rd.w := 0; rd.endW := 0 + | ORD(para): +(* + IF rd.hideMarks THEN + rd.w := 0; rd.h := 0; rd.dsc := 0 + ELSE + rd.w := ExtendToEOL(rd.x, Right(ra, rd.vw)) + 1 + END; + INC(rd.h, ra.lead); + rd.textOpts := {TextModels.hideable}; + rd.endW := rd.w +*) +(* + rd.setterOpts := {lineBreak}; +*) + IF rd.hideMarks THEN rd.h := 0; rd.dsc := 0 END; + INC(rd.h, ra.lead); rd.textOpts := {TextModels.hideable}; + IF (rd.view = NIL) OR ~(rd.view IS TextRulers.Ruler) THEN + rd.w := 10000 * Ports.mm (* ExtendToEOL(rd.x, Right(ra, rd.vw)) + 1 *) + END; + rd.endW := rd.w +(**) + | ORD(" "): + rd.setterOpts := {flexWidth}; + rd.w := rd.attr.font.StringWidth(rd.string); rd.endW := 0; INC(rd.spaces) + | ORD(zwspace): + rd.w := 0; rd.endW := 0 + | ORD(digitspace): + rd.setterOpts := {wordPart}; + rd.w := rd.attr.font.StringWidth("0"); rd.endW := rd.w + | ORD("-"): + rd.setterOpts := {}; + rd.w := rd.attr.font.StringWidth("-"); rd.endW := rd.w + | ORD(hyphen): + rd.setterOpts := {}; + rd.string[0] := "-" (*softhyphen*); + rd.w := rd.attr.font.StringWidth("-" (*softhyphen*)); rd.endW := rd.w + | ORD(nbhyphen): + rd.setterOpts := {wordJoin, wordPart}; + rd.string[0] := "-" (*softhyphen*); + rd.w := rd.attr.font.StringWidth("-" (*softhyphen*)); rd.endW := rd.w + | ORD(softhyphen): + rd.setterOpts := {wordPart}; rd.textOpts := {TextModels.hideable}; + rd.string[0] := "-"; + rd.endW := rd.attr.font.StringWidth("-" (*softhyphen*)); + IF rd.hideMarks THEN rd.w := 0 ELSE rd.w := rd.endW END + ELSE + rd.setterOpts := {wordJoin}; + IF WordPart(rd.string[0], rd.r.char) THEN INCL(rd.setterOpts, wordPart) END; + rd.w := rd.attr.font.StringWidth(rd.string); rd.endW := rd.w + END + END SpecialChar; +(* + PROCEDURE LongChar (rd: StdReader); + VAR ra: TextRulers.Attributes; + BEGIN + ra := rd.ruler.style.attr; + rd.setterOpts := {wordJoin, wordPart}; + rd.w := rd.attr.font.StringWidth(rd.string); rd.endW := rd.w + END LongChar; +*) + + PROCEDURE (rd: StdReader) Read; + (* pre: connected *) + VAR ra: TextRulers.Attributes; asc, dsc, w: INTEGER; ch: CHAR; + BEGIN + rd.Read^; + IF ~rd.eot THEN + IF rd.view = NIL THEN + rd.attr.font.GetBounds(asc, dsc, w); + rd.h := asc + dsc; rd.dsc := dsc + ELSE + GetViewPref(rd) + END; + IF (rd.view = NIL) OR (TextModels.maskChar IN rd.textOpts) THEN + ch := rd.string[0]; + IF (rd.view = NIL) + & ( (" " < ch) & (ch < "~") & (ch # "-") + OR (ch = digitspace) + OR (ch >= nbspace) & (ch # softhyphen) + ) + THEN + GatherString(rd) + ELSE + SpecialChar(rd) + END + END + ELSE + ra := rd.ruler.style.attr; + rd.w := 0; rd.endW := 0; rd.h := ra.asc + ra.dsc; rd.dsc := ra.dsc + END + END Read; + + PROCEDURE (rd: StdReader) AdjustWidth (start, pos: INTEGER; IN box: LineBox; VAR w: INTEGER); + VAR i: INTEGER; form: SET; + BEGIN + IF box.adj & (pos >= start + box.adjOff) THEN + form := box.ruler.style.attr.opts * adjustMask; + IF (form = blocked) & (rd.string[0] = " ") THEN + INC(w, box.adjW DIV box.spaces) + ELSIF (form # blocked) & (rd.string[0] = tab) THEN + INC(w, box.adjW) (* is this correct ??? *) + END + END; + i := rd.tabIndex; (* rd.string[0] = tab => i >= 0 *) + IF (rd.string[0] = tab) & (i < box.ruler.style.attr.tabs.len) THEN + w := box.tabW[i] + END + END AdjustWidth; + + PROCEDURE (rd: StdReader) SplitWidth (w: INTEGER): INTEGER; + BEGIN + IF (rd.string[1] = 0X) & (rd.view = NIL) THEN + RETURN (w + 1) DIV 2 + ELSE RETURN w + END + END SplitWidth; + + + (* Worder *) + + PROCEDURE SetWorder (VAR w: Worder; s: StdSetter; pos: INTEGER; OUT start: INTEGER); + CONST wordCutoff = LEN(s.rd.string); + BEGIN + start := s.ThisSequence(pos); + IF pos - start >= wordCutoff THEN + start := pos; WHILE pos - start < wordCutoff DO start := s.PreviousLine(start) END + END; + s.GetLine(start, w.box); w.next := start + w.box.len; + s.rd.Set(s.r, s.text, w.box.left, start, w.box.ruler, w.box.rpos, s.vw, s.hideMarks); + w.i := 0; s.rd.string[0] := 0X + END SetWorder; + + PROCEDURE StepWorder (VAR w: Worder; s: StdSetter; VAR part: BOOLEAN); + VAR rd: Reader; + BEGIN + rd := s.rd; + IF rd.string[w.i] = 0X THEN + IF rd.pos < w.next THEN + rd.Read; w.i := 0 + ELSE + IF ~w.box.eot THEN + s.GetLine(w.next, w.box); + s.rd.Set(s.r, s.text, w.box.left, w.next, w.box.ruler, w.box.rpos, s.vw, s.hideMarks); + rd.Read; w.i := 0; + INC(w.next, w.box.len) + ELSE + rd.string[0] := 0X + END + END + END; + IF rd.string[0] = 0X THEN (* end of text *) + part := TRUE + ELSIF rd.string[1] = 0X THEN (* special character *) + part := wordPart IN rd.setterOpts; INC(w.i) + ELSE (* gathered sString *) + part := WordPart(rd.string[w.i], rd.string[w.i + 1]); INC(w.i) + END + END StepWorder; + + + (* StdSetter *) + + PROCEDURE (s: StdSetter) CopyFrom (source: Stores.Store); + BEGIN + s.CopyFrom^(source); + WITH source: StdSetter DO + s.ruler := source.ruler; s.rpos := source.rpos; s.key := source.key; + s.rd := NIL; s.r := NIL + END + END CopyFrom; + + PROCEDURE (s: StdSetter) Externalize (VAR wr: Stores.Writer); + BEGIN + s.Externalize^(wr); + wr.WriteVersion(maxStdVersion) + END Externalize; + + PROCEDURE (s: StdSetter) Internalize (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + s.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + s.text := NIL; s.defRuler := NIL; s.ruler := NIL; s.rd := NIL; s.r := NIL + END Internalize; + + + PROCEDURE (s: StdSetter) ConnectTo (text: TextModels.Model; + defRuler: TextRulers.Ruler; vw: INTEGER; hideMarks: BOOLEAN + ); + BEGIN + s.ConnectTo^(text, defRuler, vw, hideMarks); + ClearCache(s.key); + IF text # NIL THEN + s.ruler := defRuler; s.rpos := -1; s.key := nextKey; INC(nextKey) + ELSE + s.ruler := NIL + END + END ConnectTo; + + + PROCEDURE (s: StdSetter) ThisPage (pageH: INTEGER; pageNo: INTEGER): INTEGER; + (* pre: connected, 0 <= pageNo *) + (* post: (result = -1) & (pageNo >= maxPageNo) OR (result = pageStart(pageNo)) *) + VAR start, prev: INTEGER; + BEGIN + ASSERT(s.text # NIL, 20); ASSERT(pageNo >= 0, 21); + start := 0; + WHILE pageNo > 0 DO + prev := start; DEC(pageNo); start := s.NextPage(pageH, start); + IF start = prev THEN start := -1; pageNo := 0 END + END; + RETURN start + END ThisPage; + + PROCEDURE (s: StdSetter) NextPage (pageH: INTEGER; start: INTEGER): INTEGER; + (* pre: connected, ThisPage(pageH, x) = start *) + (* post: (result = s.text.Length()) OR result = next-pageStart(start) *) + CONST + noBreakInside = TextRulers.noBreakInside; + pageBreak = TextRulers.pageBreak; + parJoin = TextRulers.parJoin; + regular = 0; protectInside = 1; joinFirst = 2; joinNext = 3; confirmSpace = 4; (* state *) + VAR + box: LineBox; ra: TextRulers.Attributes; + h, asc, dsc, backup, pos, state: INTEGER; isRuler: BOOLEAN; + + PROCEDURE FetchNextLine; + BEGIN + s.GetLine(pos, box); + IF box.len > 0 THEN + ra := box.ruler.style.attr; isRuler := box.rpos = pos; + asc := box.asc + s.GridOffset(dsc, box); dsc := box.dsc; h := asc + dsc + END + END FetchNextLine; + + PROCEDURE HandleRuler; + CONST norm = 0; nbi = 1; pj = 2; + VAR strength: INTEGER; + BEGIN + IF isRuler & (pos > start) & ~(pageBreak IN ra.opts) THEN + IF parJoin IN ra.opts THEN strength := pj + ELSIF noBreakInside IN ra.opts THEN strength := nbi + ELSE strength := norm + END; + CASE state OF + | regular: + CASE strength OF + | norm: + | nbi: state := protectInside; backup := pos + | pj: state := joinFirst; backup := pos + END + | protectInside: + CASE strength OF + | norm: state := regular + | nbi: backup := pos + | pj: state := joinFirst; backup := pos + END + | joinFirst: + CASE strength OF + | norm: state := confirmSpace + | nbi: state := protectInside + | pj: state := joinNext + END + | joinNext: + CASE strength OF + | norm: state := confirmSpace + | nbi: state := protectInside + | pj: + END + | confirmSpace: + CASE strength OF + | norm: state := regular + | nbi: state := protectInside; backup := pos + | pj: state := joinFirst; backup := pos + END + END + END + END HandleRuler; + + PROCEDURE IsEmptyLine (): BOOLEAN; + BEGIN + RETURN (box.right = box.left) OR s.hideMarks & isRuler & ~(pageBreak IN ra.opts) + END IsEmptyLine; + + BEGIN + ASSERT(s.text # NIL, 20); + ASSERT(0 <= start, 21); ASSERT(start <= s.text.Length(), 22); + pos := start; dsc := -1; + FetchNextLine; + IF box.len > 0 THEN + state := regular; + REPEAT (* at least one line per page *) + HandleRuler; DEC(pageH, h); INC(pos, box.len); + IF (state = confirmSpace) & ~IsEmptyLine() THEN state := regular END; + FetchNextLine + UNTIL (box.len = 0) OR (pageH - h < 0) OR isRuler & (pageBreak IN ra.opts); + IF ~isRuler OR ~(pageBreak IN ra.opts) THEN + WHILE (box.len > 0) & IsEmptyLine() DO (* skip empty lines at top of page *) + HandleRuler; INC(pos, box.len); FetchNextLine + END + END; + HandleRuler; + IF (state # regular) & ~(isRuler & (pageBreak IN ra.opts) OR (box.len = 0)) THEN pos := backup END + END; + RETURN pos + END NextPage; + + + PROCEDURE (s: StdSetter) NextSequence (start: INTEGER): INTEGER; + (* pre: connected, ThisSequence(start) = start *) + (* post: (result = start) & last-line(start) OR (ThisSequence(t, result - 1) = start) *) + VAR rd: TextModels.Reader; ch: CHAR; + BEGIN + ASSERT(s.text # NIL, 20); + s.r := s.text.NewReader(s.r); rd := s.r; rd.SetPos(start); + REPEAT rd.ReadChar(ch) UNTIL rd.eot OR (ch = line) OR (ch = para); + IF rd.eot THEN RETURN start ELSE RETURN rd.Pos() END + END NextSequence; + + PROCEDURE (s: StdSetter) ThisSequence (pos: INTEGER): INTEGER; + (* pre: connected, 0 <= pos <= t.Length() *) + (* post: (result = 0) OR (char(result - 1) IN {line, para}) *) + VAR rd: TextModels.Reader; start, limit: INTEGER; ch: CHAR; + BEGIN + ASSERT(s.text # NIL, 20); ASSERT(0 <= pos, 21); ASSERT(pos <= s.text.Length(), 22); + IF pos = 0 THEN + RETURN 0 + ELSE + start := CachedSeqStart(s.key, pos); + IF start < 0 THEN + s.r := s.text.NewReader(s.r); rd := s.r; rd.SetPos(pos); + limit := paraShutoff; + REPEAT rd.ReadPrevChar(ch); DEC(limit) + UNTIL rd.eot OR (ch = line) OR (ch = para) OR (limit = 0); + IF rd.eot THEN start := 0 ELSE start := rd.Pos() + 1 END; + AddSeqStartToCache(s.key, pos, start) + END; + RETURN start + END + END ThisSequence; + + PROCEDURE (s: StdSetter) PreviousSequence (start: INTEGER): INTEGER; + (* pre: connected, ThisSequence(t, start) = start *) + (* post: (result = 0) & (start = 0) OR (result = ThisSequence(t, start - 1)) *) + BEGIN + IF start <= 1 THEN RETURN 0 ELSE RETURN s.ThisSequence(start - 1) END + END PreviousSequence; + + + PROCEDURE (s: StdSetter) ThisLine (pos: INTEGER): INTEGER; + (* pre: connected *) + VAR start, next: INTEGER; + BEGIN + next := s.ThisSequence(pos); + REPEAT start := next; next := s.NextLine(start) UNTIL (next > pos) OR (next = start); + RETURN start + END ThisLine; + + PROCEDURE (s: StdSetter) NextLine (start: INTEGER): INTEGER; + (* pre: connected, ThisLine(start) = start *) + (* post: (result = 0) & (start = 0) OR + (result = start) & last-line(start) OR + (ThisLine(result - 1) = start) *) + VAR box: LineBox; len: INTEGER; i: INTEGER; eot: BOOLEAN; + BEGIN + i := CacheIndex(s.key, start); + IF i >= 0 THEN + len := boxCache[i].line.len; eot := boxCache[i].line.eot + ELSE + s.GetLine(start, box); len := box.len; eot := box.eot + END; + IF ~eot THEN RETURN start + len ELSE RETURN start END + END NextLine; + + PROCEDURE (s: StdSetter) PreviousLine (start: INTEGER): INTEGER; + (* pre: connected, ThisLine(start) = start *) + (* post: (result = 0) & (start = 0) OR (result = ThisLine(start - 1)) *) + BEGIN + IF start <= 1 THEN start := 0 ELSE start := s.ThisLine(start - 1) END; + RETURN start + END PreviousLine; + + + PROCEDURE (s: StdSetter) GetWord (pos: INTEGER; OUT beg, end: INTEGER); + (* pre: connected, 0 <= pos <= s.text.Length() *) + (* post: beg <= pos <= end *) + CONST wordCutoff = LEN(s.rd.string); + VAR w: Worder; part: BOOLEAN; + BEGIN + ASSERT(s.text # NIL, 20); ASSERT(0 <= pos, 21); ASSERT(pos <= s.text.Length(), 22); + SetWorder(w, s, pos, beg); end := beg; + REPEAT + StepWorder(w, s, part); INC(end); + IF ~part THEN beg := end END + UNTIL end >= pos; + DEC(end); + REPEAT + StepWorder(w, s, part); INC(end) + UNTIL ~part OR (s.rd.string[0] = 0X) OR (end - beg > wordCutoff) + END GetWord; + + PROCEDURE (s: StdSetter) GetLine (start: INTEGER; OUT box: LineBox); + VAR rd: Reader; ra: TextRulers.Attributes; brk: LineBox; + d, off, right, w: INTEGER; i, tabsN: INTEGER; form: SET; adj: BOOLEAN; ch: CHAR; + + PROCEDURE TrueW (VAR b: LineBox; w: INTEGER): INTEGER; + VAR i: INTEGER; type: SET; + BEGIN + i := rd.tabIndex; + IF (0 <= i ) & (i < TextRulers.maxTabs) & (rd.string[0] # tab) THEN + type := rd.tabType * {TextRulers.centerTab, TextRulers.rightTab}; + IF type = {TextRulers.centerTab} THEN + DEC(w, b.tabW[i] - MAX(minTabWidth, b.tabW[i] - w DIV 2)) + ELSIF type = {TextRulers.rightTab} THEN + DEC(w, b.tabW[i] - MAX(minTabWidth, b.tabW[i] - w)) + END + END; + RETURN w + END TrueW; + + PROCEDURE Enclose (VAR b: LineBox; w: INTEGER); + VAR off, i, d: INTEGER; type: SET; + BEGIN + b.len := rd.pos - start; INC(b.right, w); + off := rd.attr.offset; i := rd.tabIndex; + IF rd.h - rd.dsc + off > b.asc THEN b.asc := rd.h - rd.dsc + off END; + IF rd.dsc - off > b.dsc THEN b.dsc := rd.dsc - off END; + IF rd.view # NIL THEN b.views := TRUE END; + IF (0 <= i ) & (i < TextRulers.maxTabs) THEN + IF rd.string[0] = tab THEN + b.tabW[i] := w + ELSE + type := rd.tabType * {TextRulers.centerTab, TextRulers.rightTab}; + IF type = {TextRulers.centerTab} THEN + d := b.tabW[i] - MAX(minTabWidth, b.tabW[i] - w DIV 2); + DEC(b.tabW[i], d); DEC(b.right, d) + ELSIF type = {TextRulers.rightTab} THEN + d := b.tabW[i] - MAX(minTabWidth, b.tabW[i] - w); + DEC(b.tabW[i], d); DEC(b.right, d) + END + END + END + END Enclose; + + BEGIN + ASSERT(s.text # NIL, 20); ASSERT(0 <= start, 21); ASSERT(start <= s.text.Length(), 22); + i := CacheIndex(s.key, start); + IF i >= 0 THEN + GetFromCache(s, i, box) + ELSE + TextRulers.GetValidRuler(s.text, start, s.rpos, s.ruler, s.rpos); + IF s.rpos > start THEN s.ruler := s.defRuler; s.rpos := -1 END; + box.ruler := s.ruler; box.rpos := s.rpos; + ra := s.ruler.style.attr; tabsN := ra.tabs.len; right := Right(ra, s.vw); + s.r := s.text.NewReader(s.r); + IF start = 0 THEN s.r.SetPos(start); ch := para + ELSE s.r.SetPos(start - 1); s.r.ReadChar(ch) + END; + s.r.Read; + +(* + IF s.r.char = para THEN box.rbox := ~s.hideMarks; box.bop := s.hideMarks; box.left := 0 + ELSIF ch = para THEN box.rbox := FALSE; box.bop := TRUE; box.left := ra.first + ELSE box.rbox := FALSE; box.bop := FALSE; box.left := ra.left + END; +*) + IF s.r.char = para THEN box.rbox := TRUE; box.bop := FALSE; box.left := 0 + ELSIF ch = para THEN box.rbox := FALSE; box.bop := TRUE; box.left := ra.first + ELSE box.rbox := FALSE; box.bop := FALSE; box.left := ra.left + END; +(**) + box.views := FALSE; + box.asc := 0; box.dsc := 0; box.right := box.left; + box.len := 0; box.adjOff := 0; box.spaces := 0; + brk.right := 0; + + s.rd := s.NewReader(s.rd); rd := s.rd; + rd.Set(s.r, s.text, box.left, start, box.ruler, box.rpos, s.vw, s.hideMarks); + rd.Read; + WHILE ~rd.eot & (box.right + (*rd.w*) TrueW(box, rd.w) <= right) + & ~(lineBreak IN rd.setterOpts) DO + IF ~(wordJoin IN rd.setterOpts) & (box.right + rd.endW <= right) THEN + (*brk := box;*) + brk.len := box.len; brk.ruler := box.ruler; brk.rpos := box.rpos; + brk.left := box.left; brk.right := box.right; brk.asc := box.asc; brk.dsc := box.dsc; + brk.rbox := box.rbox; brk.bop := box.bop; brk.adj := box.adj; brk.eot := box.eot; + brk.views := box.views; brk.skipOff := box.skipOff; brk.adjOff := box.adjOff; + brk.spaces := box.spaces; brk.adjW := box.adjW; + i := 0; WHILE i < tabsN DO brk.tabW[i] := box.tabW[i]; INC(i) END; + (*---*) + Enclose(brk, rd.endW); + brk.eot := rd.r.eot (* rd.r.eot one ahead of rd.eot *) + END; + box.adjOff := rd.adjStart - start; box.spaces := rd.spaces; + Enclose(box, rd.w); + rd.x := box.right; rd.Read + END; + IF (lineBreak IN rd.setterOpts) (* & ~box.rbox *) THEN Enclose(box, 0) END; + box.eot := rd.eot; adj := FALSE; box.skipOff := box.len; + IF box.right + rd.w > right THEN (* rd.w > 0 => ~rd.eot & ~(lineBreak IN setterOpts) *) + IF ~(wordJoin IN rd.setterOpts) & (box.right + rd.endW <= right) THEN + IF rd.string[0] = " " THEN DEC(box.spaces) END; + Enclose(box, rd.endW); + adj := TRUE + ELSIF brk.right > 0 THEN + (*box := brk;*) + box.len := brk.len; box.ruler := brk.ruler; box.rpos := brk.rpos; + box.left := brk.left; box.right := brk.right; box.asc := brk.asc; box.dsc := brk.dsc; + box.rbox := brk.rbox; box.bop := brk.bop; box.adj := brk.adj; box.eot := brk.eot; + box.views := brk.views; box.skipOff := brk.skipOff; box.adjOff := brk.adjOff; + box.spaces := brk.spaces; box.adjW := brk.adjW; + i := 0; WHILE i < tabsN DO box.tabW[i] := brk.tabW[i]; INC(i) END; + (*---*) + box.skipOff := box.len - 1; adj := TRUE + ELSIF box.right = box.left THEN + Enclose(box, rd.w) (* force at least one per line *) + END + ELSIF (box.right = box.left) & box.eot THEN + box.asc := ra.asc; box.dsc := ra.dsc (* force empty line to ruler's default height *) + END; + + box.adj := FALSE; + d := right - box.right; + IF d > 0 THEN + form := ra.opts * adjustMask; + IF form = blocked THEN + IF adj & (box.spaces > 0) THEN + box.right := right; box.adj := TRUE; box.adjW := d + END + ELSIF form = rightFlush THEN + IF box.adjOff > 0 THEN + box.adjW := d; box.adj := TRUE + ELSE + INC(box.left, d) + END; + box.right := right + ELSIF form = centered THEN + IF box.adjOff > 0 THEN + box.adjW := d DIV 2; box.adj := TRUE + ELSE + INC(box.left, d DIV 2) + END; + INC(box.right, d DIV 2) + END + END; + + AddToCache(s.key, start, box) + END; + + ASSERT(box.eot OR (box.len > 0), 100) + END GetLine; + + + PROCEDURE (s: StdSetter) GetBox (start, end, maxW, maxH: INTEGER; OUT w, h: INTEGER); + VAR box: LineBox; asc, dsc: INTEGER; + BEGIN + ASSERT(s.text # NIL, 20); + ASSERT(0 <= start, 21); + ASSERT(start <= end, 22); + ASSERT(end <= s.text.Length(), 23); + w := 0; h := 0; dsc := -1; + IF maxW <= Views.undefined THEN maxW := MAX(INTEGER) END; + IF maxH <= Views.undefined THEN maxH := MAX(INTEGER) END; + WHILE (start < end) & (h < maxH) DO + s.GetLine(start, box); + IF box.rbox THEN w := MAX(w, Right(box.ruler.style.attr, s.vw)) + ELSE w := MAX(w, box.right) + END; + asc := box.asc + s.GridOffset(dsc, box); dsc := box.dsc; + INC(start, box.len); INC(h, asc + dsc) + END; + w := MIN(w, maxW); h := MIN(h, maxH) + END GetBox; + + + PROCEDURE (s: StdSetter) NewReader (old: Reader): Reader; + (* pre: connected *) + VAR rd: StdReader; + BEGIN + ASSERT(s.text # NIL, 20); + IF (old # NIL) & (old IS StdReader) THEN RETURN old + ELSE NEW(rd); RETURN rd + END + END NewReader; + + + PROCEDURE (s: StdSetter) GridOffset (dsc: INTEGER; IN box: LineBox): INTEGER; + VAR ra: TextRulers.Attributes; h, h0: INTEGER; + (* minimal possible line spacing h0, minimal legal line spacing h *) + BEGIN + IF ~box.rbox THEN + ra := box.ruler.style.attr; + IF dsc < 0 THEN +RETURN 0 (* no longer try to correct first line's grid position -- should be done when printing... *) +(* + h0 := box.asc; h := ra.asc; + IF h < h0 THEN (* override legal spacing if to small *) + h := h - (h - h0) DIV ra.grid * ra.grid (* adjust to next larger grid line *) + END; + RETURN h - h0 +*) + ELSE + h0 := box.asc + dsc; h := ra.asc + ra.dsc; + IF h < h0 THEN h := h0 END; (* override legal spacing if to small *) + RETURN - (-h) DIV ra.grid * ra.grid - h0 (* adjust to next larger grid line *) + END + ELSE + RETURN 0 + END + END GridOffset; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (): Setter; + VAR s: StdSetter; + BEGIN + NEW(s); s.text := NIL; RETURN s + END New; + + + (** miscellaneous **) + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + InitCache; + NEW(d); dir := d; stdDir := d + END Init; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); dir := d + END SetDir; + +BEGIN + Init +END TextSetters. diff --git a/Trurl-based/Text/Mod/Views.odc b/Trurl-based/Text/Mod/Views.odc new file mode 100644 index 0000000..6f0fb5f Binary files /dev/null and b/Trurl-based/Text/Mod/Views.odc differ diff --git a/Trurl-based/Text/Mod/Views.txt b/Trurl-based/Text/Mod/Views.txt new file mode 100644 index 0000000..2ee55ea --- /dev/null +++ b/Trurl-based/Text/Mod/Views.txt @@ -0,0 +1,1579 @@ +MODULE TextViews; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Text/Mod/Views.odc *) + (* DO NOT EDIT *) + +(* could use +, $ in DrawLine cache implementation *) + + IMPORT + Services, Fonts, Ports, Stores, + Models, Views, Controllers, Properties, Dialog, Printing, Containers, + TextModels, TextRulers, TextSetters; + + CONST + (** v.DisplayMarks hide *) + show* = FALSE; hide* = TRUE; + + (** v.ShowRange focusOnly **) + any* = FALSE; focusOnly* = TRUE; + + parasign = 0B6X; (* paragraph sign, to mark non-ruler paragraph breaks *) + + mm = Ports.mm; inch16 = Ports.inch DIV 16; point = Ports.point; + maxScrollHeight = 16 * point; maxScrollSteps = 100; fuseScrollHeight = maxScrollHeight DIV 2; + maxHeight = maxScrollHeight * maxScrollSteps; + adjustMask = {TextRulers.leftAdjust, TextRulers.rightAdjust}; + + (* SetOp.mode *) + setMarks = 0; setSetter = 1; setDefs = 2; + + scrollingKey = "#System:Scrolling"; + viewSettingKey = "#System:ViewSetting"; + + minVersion = 0; maxVersion = 0; maxStdVersion = 0; + + + TYPE + View* = POINTER TO ABSTRACT RECORD (Containers.View) END; + + Directory* = POINTER TO ABSTRACT RECORD + defAttr-: TextModels.Attributes + END; + + + Location* = RECORD + (** start of line and position of location **) + start*, pos*: INTEGER; + (** coordinates of location **) + x*, y*: INTEGER; + (** line dimensions at location **) + asc*, dsc*: INTEGER; + (** if view at location: **) + view*: Views.View; + l*, t*, r*, b*: INTEGER + END; + + + PositionMsg* = RECORD (Models.Message) + focusOnly*: BOOLEAN; + beg*, end*: INTEGER + END; + + + PageMsg* = RECORD (Properties.Message) + current*: INTEGER + END; + + + Line = POINTER TO RECORD + next: Line; + start, asc, h: INTEGER; + attr: TextRulers.Attributes; (* attr = box.ruler.style.attr *) + box: TextSetters.LineBox (* caching of box.rpos not consistent *) + END; + + StdView = POINTER TO RECORD (View) + (* model *) + text: TextModels.Model; + org: INTEGER; + dy: INTEGER; (* 0 <= dy < Height(first line) *) + defRuler: TextRulers.Ruler; + defAttr: TextModels.Attributes; + hideMarks: BOOLEAN; + (* general state *) + cachedRd: TextSetters.Reader; + (* line grid cache *) + trailer: Line; (* trailer # NIL => trailer.eot, trailer.next # trailer *) + bot: INTEGER; (* max(f : f seen by Restore : f.b) *) + (* setter *) + setter, setter0: TextSetters.Setter (* setter # setter0 lazily detects setter change *) + END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + ScrollOp = POINTER TO RECORD (Stores.Operation) + v: StdView; + org, dy: INTEGER; + bunchOrg, bunchDy: INTEGER; + bunch: BOOLEAN; (* bunch => bunchOrg, bunchDy valid *) + silent: BOOLEAN (* original caller of Do(op) already handled situation *) + END; + + SetOp = POINTER TO RECORD (Stores.Operation) + mode: INTEGER; + view: StdView; + hideMarks: BOOLEAN; + setter: TextSetters.Setter; + defRuler: TextRulers.Ruler; + defAttr: TextModels.Attributes + END; + + FindAnyFrameMsg = RECORD (Views.Message) + (* find frame with smallest height (frame.b - frame.t) that displays view; NIL if none found *) + frame: Views.Frame (* OUT, initially NIL *) + END; + + FindFocusFrameMsg = RECORD (Controllers.Message) + (* find outermost focus frame displaying view; NIL if none found *) + view: Views.View; (* IN *) + frame: Views.Frame (* OUT, initially NIL *) + END; + + + VAR + ctrlDir-: Containers.Directory; + dir-, stdDir-: Directory; + + + (* forward used in GetStart, UpdateView, ShowRangeIn *) + PROCEDURE ^ DoSetOrigin (v: StdView; org, dy: INTEGER; silent: BOOLEAN); + + + (** View **) + + PROCEDURE (v: View) Internalize2- (VAR rd: Stores.Reader), EXTENSIBLE; + (** pre: ~v.init **) + (** post: v.init **) + VAR thisVersion: INTEGER; + BEGIN + (*v.Internalize^(rd);*) + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion) + END Internalize2; + + PROCEDURE (v: View) Externalize2- (VAR wr: Stores.Writer), EXTENSIBLE; + (** pre: v.init **) + BEGIN + (*v.Externalize^(wr);*) + wr.WriteVersion(maxVersion) + END Externalize2; + + PROCEDURE (v: View) ThisModel* (): TextModels.Model, EXTENSIBLE; + VAR m: Containers.Model; + BEGIN + m := v.ThisModel^(); + IF m # NIL THEN + RETURN m(TextModels.Model) + ELSE + RETURN NIL + END + END ThisModel; + + PROCEDURE (v: View) DisplayMarks* (hide: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (v: View) HidesMarks* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (v: View) SetSetter* (setter: TextSetters.Setter), NEW, ABSTRACT; + PROCEDURE (v: View) ThisSetter* (): TextSetters.Setter, NEW, ABSTRACT; + PROCEDURE (v: View) SetOrigin* (org, dy: INTEGER), NEW, ABSTRACT; + (** post: org = ThisLine(org) => v.org = org, v.dy = dy; else v.org = ThisLine(org), v.dy = 0 **) + + PROCEDURE (v: View) PollOrigin* (OUT org, dy: INTEGER), NEW, ABSTRACT; + PROCEDURE (v: View) SetDefaults* (r: TextRulers.Ruler; a: TextModels.Attributes), + NEW, ABSTRACT; + (** pre: r.init, a.init **) + + PROCEDURE (v: View) PollDefaults* (OUT r: TextRulers.Ruler; OUT a: TextModels.Attributes), + NEW, ABSTRACT; + PROCEDURE (v: View) GetThisLocation* (f: Views.Frame; pos: INTEGER; OUT loc: Location), + NEW, ABSTRACT; + + PROCEDURE (v: View) GetRect* (f: Views.Frame; view: Views.View; OUT l, t, r, b: INTEGER); + VAR con: Models.Context; loc: Location; pos: INTEGER; + BEGIN + con := view.context; + ASSERT(con # NIL, 20); ASSERT(con.ThisModel() = v.ThisModel(), 21); + pos := con(TextModels.Context).Pos(); + v.GetThisLocation(f, pos, loc); + IF loc.view = view THEN + l := loc.l; t := loc.t; r := loc.r; b := loc.b + ELSE + l := MAX(INTEGER); t := MAX(INTEGER); r := l; b := t + END + END GetRect; + + PROCEDURE (v: View) GetRange* (f: Views.Frame; OUT beg, end: INTEGER), NEW, ABSTRACT; + (** post: beg = beg of first visible line, end = end of last visible line **) + + PROCEDURE (v: View) ThisPos* (f: Views.Frame; x, y: INTEGER): INTEGER, NEW, ABSTRACT; + PROCEDURE (v: View) ShowRangeIn* (f: Views.Frame; beg, end: INTEGER), NEW, ABSTRACT; + PROCEDURE (v: View) ShowRange* (beg, end: INTEGER; focusOnly: BOOLEAN), NEW, ABSTRACT; + (** post: in all frames (resp. in front or otherwise target frame if focusOnly): + if possible, first visible pos <= k <= last visible pos, + with k = beg if beg = end and beg <= k < end otherwise **) + + + (** Directory **) + + PROCEDURE (d: Directory) Set* (defAttr: TextModels.Attributes), NEW, EXTENSIBLE; + BEGIN + ASSERT(defAttr # NIL, 20); ASSERT(defAttr.init, 21); + d.defAttr := defAttr + END Set; + + PROCEDURE (d: Directory) New* (text: TextModels.Model): View, NEW, ABSTRACT; + + + (** miscellaneous **) + + PROCEDURE SetCtrlDir* (d: Containers.Directory); + BEGIN + ASSERT(d # NIL, 20); ctrlDir := d + END SetCtrlDir; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); dir := d + END SetDir; + + + PROCEDURE Focus* (): View; + VAR v: Views.View; + BEGIN + v := Controllers.FocusView(); + IF (v # NIL) & (v IS View) THEN RETURN v(View) ELSE RETURN NIL END + END Focus; + + PROCEDURE FocusText* (): TextModels.Model; + VAR v: View; + BEGIN + v := Focus(); + IF v # NIL THEN RETURN v.ThisModel() ELSE RETURN NIL END + END FocusText; + + PROCEDURE Deposit*; + BEGIN + Views.Deposit(dir.New(NIL)) + END Deposit; + + + PROCEDURE ShowRange* (text: TextModels.Model; beg, end: INTEGER; focusOnly: BOOLEAN); + (** post: in all front or target frames displaying a view displaying t: + if possible, first visible pos <= k <= last visible pos, + with k = beg if beg = end and beg <= k < end otherwise **) + VAR pm: PositionMsg; + BEGIN + ASSERT(text # NIL, 20); + pm.beg := beg; pm.end := end; pm.focusOnly := focusOnly; + Models.Broadcast(text, pm) + END ShowRange; + + + PROCEDURE ThisRuler* (v: View; pos: INTEGER): TextRulers.Ruler; + VAR r: TextRulers.Ruler; a: TextModels.Attributes; rpos: INTEGER; + BEGIN + v.PollDefaults(r, a); rpos := -1; TextRulers.GetValidRuler(v.ThisModel(), pos, -1, r, rpos); + RETURN r + END ThisRuler; + + + (* auxiliary procedures *) + + PROCEDURE GetReader (v: StdView; start: INTEGER; IN box: TextSetters.LineBox + ): TextSetters.Reader; + VAR st: TextSetters.Setter; rd: TextSetters.Reader; + BEGIN + ASSERT(box.ruler # NIL, 100); + st := v.ThisSetter(); + rd := v.cachedRd; v.cachedRd := NIL; (* reader recycling *) + rd := st.NewReader(rd); + rd.Set(rd.r, v.text, box.left, start, box.ruler, box.rpos, st.vw, st.hideMarks); + RETURN rd + END GetReader; + + PROCEDURE CacheReader (v: StdView; rd: TextSetters.Reader); + BEGIN + ASSERT(v.cachedRd = NIL, 20); + v.cachedRd := rd + END CacheReader; + + + (* line descriptors *) + + PROCEDURE SetLineAsc (st: TextSetters.Setter; t: Line; dsc: INTEGER); + (* pre: dsc: descender of previous line (-1 if first line) *) + BEGIN + t.asc := t.box.asc + st.GridOffset(dsc, t.box); + t.h := t.asc + t.box.dsc + END SetLineAsc; + + PROCEDURE NewLine (st: TextSetters.Setter; start, dsc: INTEGER): Line; + (* pre: start: start of line to measure; dsc: descender of previous line (-1 if first line) *) + VAR t: Line; + BEGIN + NEW(t); st.GetLine(start, t.box); + t.start := start; SetLineAsc(st, t, dsc); + t.attr := t.box.ruler.style.attr; + RETURN t + END NewLine; + + PROCEDURE AddLine (st: TextSetters.Setter; VAR t: Line; VAR start, y: INTEGER); + BEGIN + t.next := NewLine(st, start, t.box.dsc); t := t.next; + INC(start, t.box.len); INC(y, t.h) + END AddLine; + + PROCEDURE InitLines (v: StdView); + VAR asc, dsc, w: INTEGER; t0, t: Line; start, y: INTEGER; + BEGIN + v.defAttr.font.GetBounds(asc, dsc, w); + NEW(t0); start := v.org; y := v.dy; + t0.box.dsc := -1; (* dsc = -1: trailer.next is first line *) + t := t0; AddLine(v.ThisSetter(), t, start, y); t.next := t0; (* at least one valid line desc *) + t0.start := start; t0.asc := asc; t0.h := asc + dsc; (* trailer.(asc, h) for caret display following last line *) + t0.attr := NIL; + t0.box.eot := TRUE; t0.box.len := 0; + t0.box.ruler := NIL; + t0.box.left := -1; (* make trailer async to every other line *) + v.trailer := t0; v.bot := 0 + END InitLines; + + PROCEDURE ExtendLines (v: StdView; bot: INTEGER); + VAR st: TextSetters.Setter; t0, t: Line; start, y: INTEGER; + BEGIN + IF bot >= v.bot THEN + t0 := v.trailer; start := t0.start; + y := v.dy; t := t0; WHILE t.next # t0 DO t := t.next; INC(y, t.h) END; + IF (y < bot) & ~t.box.eot THEN + st := v.ThisSetter(); + REPEAT AddLine(st, t, start, y) UNTIL (y >= bot) OR t.box.eot; + t.next := t0; t0.start := start + END; + v.bot := bot + END + END ExtendLines; + + PROCEDURE ReduceLines (v: StdView; bot: INTEGER); + VAR t0, t: Line; y: INTEGER; + BEGIN + IF bot <= v.bot THEN + t0 := v.trailer; y := v.dy; + t := t0; WHILE (t.next # t0) & (y < bot) DO t := t.next; INC(y, t.h) END; + t0.start := t.next.start; t.next := t0; + v.bot := bot + END + END ReduceLines; + + PROCEDURE ValidateLines (v: StdView; bot: INTEGER); + VAR st: TextSetters.Setter; w, h, len: INTEGER; + BEGIN + IF v.setter # NIL THEN + v.context.GetSize(w, h); (* possibly adapt to changed width *) + IF v.setter.vw # w THEN v.setter0 := NIL; v.trailer := NIL END + END; + len := v.text.Length(); + IF (v.org > len) OR (v.trailer # NIL) & (v.trailer.start > len) THEN v.trailer := NIL END; + IF v.trailer = NIL THEN + IF v.org > len THEN v.org := len END; + st := v.ThisSetter(); v.org := st.ThisLine(v.org); + InitLines(v) + END; + ExtendLines(v, bot) + END ValidateLines; + + PROCEDURE PrependLines (v: StdView); + VAR st: TextSetters.Setter; t0, t1, t: Line; start, y: INTEGER; + BEGIN + t0 := v.trailer; start := v.org; y := v.dy; + IF t0.start # start THEN + st := v.ThisSetter(); + t := t0; t1 := t0.next; + WHILE (t1.start # start) & (y < v.bot) DO AddLine(st, t, start, y) END; + IF y >= v.bot THEN + t.next := t0; t0.start := start + ELSE + t.next := t1; + IF t1 # v.trailer THEN SetLineAsc(st, t1, t.box.dsc) END + END + END + END PrependLines; + + + (* update frame after insert/delete/replace *) + + PROCEDURE ThisViewLine (v: StdView; y: INTEGER): Line; + (* pre: 0 <= y < v.bot *) + VAR t: Line; py: INTEGER; + BEGIN + t := v.trailer.next; py := v.dy; + WHILE ~t.box.eot & (py + t.h < y) DO INC(py, t.h); t := t.next END; + RETURN t + END ThisViewLine; + + PROCEDURE LocateThisLine (v: StdView; start: INTEGER; OUT t: Line; OUT y: INTEGER); + VAR t1: Line; + BEGIN + t := v.trailer.next; y := v.dy; + t1 := v.trailer.next; + WHILE t.start # start DO INC(y, t.h); t := t.next; ASSERT(t # t1, 100) END + END LocateThisLine; + + PROCEDURE GetStart (st: TextSetters.Setter; v: StdView; beg: INTEGER; OUT start: INTEGER); + (* find start of line containing beg after text change; tuned using valid line descs *) + VAR s, t: Line; + BEGIN + s := v.trailer; t := s.next; + WHILE (t # v.trailer) & (t.start + t.box.len < beg) DO s := t; t := s.next END; + IF s # v.trailer THEN (* at least first line desc possibly still valid *) + start := st.NextLine(s.start); (* NextLine can be much cheaper than ThisLine *) + IF start # t.start THEN + GetStart(st, v, s.start, start) + ELSIF ~t.box.eot & (start + t.box.len = beg) & (st.NextLine(start) = beg) THEN + start := beg + END + ELSE + IF v.org <= v.text.Length() THEN + start := st.ThisLine(v.org) + ELSE + start := st.ThisLine(v.text.Length()) + END; + IF start < v.org THEN + DoSetOrigin(v, start, 0, TRUE) + ELSIF start > v.org THEN + start := v.org + END + END + END GetStart; + + PROCEDURE GetStringStart (v: StdView; t: Line; pos: INTEGER; OUT p1, x: INTEGER); + VAR rd: TextSetters.Reader; + BEGIN + p1 := t.start; x := t.box.left; + IF t.box.views THEN + rd := GetReader(v, p1, t.box); rd.Read; + WHILE ~rd.eot & (rd.pos <= pos) DO + rd.AdjustWidth(t.start, p1, t.box, rd.w); INC(rd.x, rd.w); + IF rd.view # NIL THEN p1 := rd.pos; x := rd.x END; + rd.Read + END; + CacheReader(v, rd) + END + END GetStringStart; + + PROCEDURE InSynch (t0, t1: Line): BOOLEAN; + BEGIN + RETURN (t0.start = t1.start) & (t0.asc = t1.asc) & (t0.attr = t1.attr) + & (t0.box.left = t1.box.left) & (t0.box.asc = t1.box.asc) & (t0.box.dsc = t1.box.dsc) + & (t0.box.rbox = t1.box.rbox) & (t0.box.bop = t1.box.bop) + END InSynch; + + PROCEDURE RebuildView (v: StdView); + BEGIN + v.setter0 := NIL; + IF v.trailer # NIL THEN v.trailer := NIL; v.bot := 0; Views.Update(v, Views.rebuildFrames) END + END RebuildView; + + PROCEDURE UpdateIn (v: StdView; l, t, b: INTEGER); + BEGIN + Views.UpdateIn(v, l, t, MAX(INTEGER), b, Views.rebuildFrames) + END UpdateIn; + + PROCEDURE UpdateFrames (v: StdView; t0, t1, u: Line; beg, y0, yu: INTEGER); + VAR t, te: Line; b, x, b0, b1, top, bot: INTEGER; + BEGIN + IF ((beg < t0.next.start) OR t0.box.eot) & ~t0.box.adj + & ((beg < t1.next.start) OR t1.box.eot) & ~t1.box.adj + & InSynch(t0, t1) THEN + GetStringStart(v, t1, beg, beg, x) + ELSE + beg := t1.start + END; + b := y0; t := t0; WHILE t # u DO INC(b, t.h); t := t.next END; + IF b = yu THEN + te := u + ELSE (* t = u *) + te := v.trailer; + b0 := b; WHILE t # v.trailer DO INC(b0, t.h); t := t.next END; + IF yu < b THEN ExtendLines(v, v.bot) ELSE ReduceLines(v, v.bot) END; + b1 := y0; t := t1; WHILE t # v.trailer DO INC(b1, t.h); t := t.next END; + IF b1 < b0 THEN UpdateIn(v, 0, b1, b0) END (* erase trailer *) + END; + IF t1.start < beg THEN (* conserve head of t1 *) + UpdateIn(v, x, y0, y0 + t1.h); (* redraw tail of t1 *) + top := y0 + t1.h + ELSE + top := y0 + END; + bot := y0; REPEAT INC(bot, t1.h); t1 := t1.next UNTIL t1 = te; + IF top < bot THEN UpdateIn(v, 0, top, bot) END (* redraw affected lines *) + END UpdateFrames; + + PROCEDURE UpdateView (v: StdView; beg, end, delta: INTEGER); + VAR st: TextSetters.Setter; r: TextRulers.Ruler; rpos: INTEGER; + s0, t0, t, tn, u: Line; start, y, y0: INTEGER; + BEGIN + IF v.trailer # NIL THEN + v.setter0 := NIL; st := v.ThisSetter(); + IF (beg <= v.trailer.start) & ((end >= v.org) OR (end - delta >= v.org)) THEN + GetStart(st, v, beg, start); + y0 := v.dy; s0 := v.trailer; + WHILE s0.next.start < start DO s0 := s0.next; INC(y0, s0.h) END; + + t := s0.next; WHILE (t # v.trailer) & (t.start < end) DO t := t.next END; + IF (t = v.trailer.next) & (t.start >= end) THEN + REPEAT + INC(t.start, delta); + IF t.box.rpos >= end THEN INC(t.box.rpos, delta) END; + t := t.next + UNTIL t = v.trailer.next + ELSE + WHILE (t # v.trailer.next) & (t.start >= end) DO + INC(t.start, delta); + IF t.box.rpos >= end THEN INC(t.box.rpos, delta) END; + t := t.next + END + END; + tn := s0; y := y0; t0 := s0.next; u := t0; + REPEAT + t := tn; AddLine(st, tn, start, y); (* start = end(tn), y = bot(tn) *) + WHILE (u # v.trailer) & (u.start < tn.start) DO u := u.next END + UNTIL tn.box.eot OR (y > v.bot) + OR (tn.start >= end) & (u.start = tn.start) & (u.box.len = tn.box.len) + & (u.asc = tn.asc) & (u.attr = tn.attr) & (u.box.dsc = tn.box.dsc) + & (u.box.rpos = tn.box.rpos); (* can be expensive ... *) + IF tn.box.eot OR (y > v.bot) THEN + t := tn; u := v.trailer; v.trailer.start := start + ELSE + DEC(y, tn.h) + END; + t.next := u; + IF (s0 # v.trailer) & (s0.next # v.trailer) THEN s0.box.eot := FALSE END; + ASSERT(v.trailer.start <= v.text.Length(), 100); + UpdateFrames(v, t0, s0.next, u, beg, y0, y) + ELSIF end <= v.org THEN + INC(v.org, delta); +(* + IF end < v.org - delta - 500 THEN start := v.org ELSE start := st.ThisLine(v.org) END; + (* this is not safe; even a change 500 characters away could force the view's origin to a + new position in order to maintain the invariant that the origin always falls on a line start; + however, ThisLine can be quite expensive -- can we rely on TextSetters cache ? *) +*) + start := st.ThisLine(v.org); + r := v.defRuler; rpos := -1; TextRulers.GetValidRuler(v.text, start, -1, r, rpos); + IF (v.org = start) & (v.trailer.next.attr = r.style.attr) THEN + t := v.trailer; + REPEAT + t := t.next; INC(t.start, delta); + IF t.box.rpos < start THEN t.box.rpos := rpos ELSE INC(t.box.rpos, delta) END + UNTIL t = v.trailer + ELSE + DoSetOrigin(v, start, 0, TRUE); RebuildView(v) + END + END + END + END UpdateView; + + PROCEDURE StyleUpdate (v: StdView; oldAttr: TextRulers.Attributes); + VAR t: Line; beg: INTEGER; first: BOOLEAN; + BEGIN + IF v.trailer # NIL THEN + t := v.trailer.next; first := TRUE; + WHILE t # v.trailer DO + WHILE (t # v.trailer) & (t.attr # oldAttr) DO t := t.next END; + IF t # v.trailer THEN + IF first THEN v.Neutralize; first := FALSE END; + beg := t.start; t := t.next; + WHILE (t # v.trailer) & (t.attr = oldAttr) DO t := t.next END; + UpdateView(v, beg, t.start, 0) + END + END + END + END StyleUpdate; + + + (* line drawing *) + + PROCEDURE DrawLine (v: StdView; + start: INTEGER; IN box: TextSetters.LineBox; + f: Views.Frame; l, r, y, t: INTEGER; pageF: BOOLEAN + ); + (* pre: area cleared *) + (* [l,r) for high-level clipping to tune update after small change *) + CONST cacheLen = 128; + VAR rd: TextSetters.Reader; ra: TextRulers.Attributes; + v1: Views.View; c: Containers.Controller; + py, end, skip: INTEGER; + cache: RECORD (* initially: long = TRUE, len = 0 *) + x, y: INTEGER; color: Ports.Color; font: Fonts.Font; + len: INTEGER; + buf: ARRAY cacheLen OF CHAR + END; + + PROCEDURE FlushCaches; + BEGIN + IF cache.len > 0 THEN + cache.buf[cache.len] := 0X; + f.DrawString(cache.x, cache.y, cache.color, cache.buf, cache.font) + END; + cache.len := 0 + END FlushCaches; + + PROCEDURE CacheString (x, y: INTEGER; c: INTEGER; IN s: ARRAY OF CHAR; + f: Fonts.Font + ); + VAR i, j, len: INTEGER; + BEGIN + len := 0; WHILE s[len] # 0X DO INC(len) END; + IF (cache.len + len >= cacheLen) OR (cache.y # y) OR (cache.color # c) OR (cache.font # f) THEN + FlushCaches + END; + ASSERT(cache.len + len < cacheLen, 100); + IF cache.len = 0 THEN cache.x := x; cache.y := y; cache.color := c; cache.font := f END; + i := 0; j := cache.len; + WHILE i < len DO cache.buf[j] := s[i]; INC(i); INC(j) END; + cache.len := j + END CacheString; + +(* + PROCEDURE CacheString (x, y: INTEGER; c: INTEGER; IN s: ARRAY OF CHAR; + f: Fonts.Font + ); + VAR i, j, len: INTEGER; + BEGIN + (* flush first, then promote *) + len := 0; WHILE s[len] # 0X DO INC(len) END; + IF (cache.len + len >= cacheLen) OR (cache.y # y) OR (cache.color # c) OR (cache.font # f) THEN + FlushCaches + END; + IF (cache.len > 0) & cache.short THEN (* promote short chars to chars *) + i := 0; WHILE i < cache.len DO cache.buf[i] := cache.sbuf[i]; INC(i) END + END; + cache.short := FALSE; + ASSERT(cache.len + len < cacheLen, 100); + IF cache.len = 0 THEN cache.x := x; cache.y := y; cache.color := c; cache.font := f END; + i := 0; j := cache.len; + WHILE i < len DO cache.buf[j] := s[i]; INC(i); INC(j) END; + cache.len := j + END CacheString; +*) + + BEGIN + IF box.len > 0 THEN + cache.len := 0; + end := start + box.len; skip := start + box.skipOff; + rd := GetReader(v, start, box); rd.Read; + WHILE ~rd.eot & (rd.pos <= end) & (rd.x < r) DO + IF rd.pos > skip THEN rd.w := rd.endW END; + rd.AdjustWidth(start, rd.pos, box, rd.w); + IF rd.x + rd.w > l THEN + v1 := rd.view; + IF v1 # NIL THEN + FlushCaches; + IF ~((TextModels.hideable IN rd.textOpts) & v.hideMarks) THEN + c := v.ThisController(); + Views.InstallFrame(f, v1, + rd.x, y - rd.attr.offset + rd.dsc - rd.h, 0, + (c # NIL) & (v1 = c.ThisFocus()) ) + END + ELSIF (rd.h > 0) & (rd.w > 0) THEN + IF box.rbox & ~v.hideMarks THEN rd.string[0] := parasign END; (* ¶ sign *) + py := y - rd.attr.offset; + IF rd.string[0] > " " THEN + CacheString(rd.x, py, rd.attr.color, rd.string, rd.attr.font); + IF ~v.hideMarks & (TextModels.hideable IN rd.textOpts) THEN + f.DrawRect(rd.x, py - box.asc + f.dot, + MIN(rd.x + rd.w, f.r), py + box.dsc - f.dot, 0, Ports.grey25) + END + ELSIF rd.string[0] # 0X THEN + FlushCaches; + IF ~v.hideMarks & (TextModels.hideable IN rd.textOpts) THEN + f.DrawRect(rd.x, py - box.asc + f.dot, rd.x + rd.w, py + box.dsc - f.dot, 0, Ports.grey25) + END + ELSE FlushCaches + END + END + END; + INC(rd.x, rd.w); rd.Read + END; + FlushCaches; + CacheReader(v, rd) + END; + IF v.hideMarks & ~pageF THEN + ra := box.ruler.style.attr; + IF TextRulers.pageBreak IN ra.opts THEN + IF (box.rpos = start) & (ra.lead >= f.dot) THEN + f.DrawLine(l, t, r - f.dot, t, 0, Ports.grey50) + ELSIF (box.rpos = start - 1) & (ra.lead < f.dot) THEN + f.DrawLine(l, t, r - f.dot, t, 0, Ports.grey50) + END + END + END + END DrawLine; + + PROCEDURE DrawDecorations (v: StdView; u: Line; f: Views.Frame; l, t, r, b: INTEGER); + VAR a: TextRulers.Attributes; i, x: INTEGER; col: Ports.Color; + st: TextSetters.Setter; srd: TextSetters.Reader; rd: TextModels.Reader; + BEGIN + IF t < b THEN + i := 0; a := u.attr; srd := NIL; + WHILE i < a.tabs.len DO + IF TextRulers.barTab IN a.tabs.tab[i].type THEN + x := a.tabs.tab[i].stop; + IF (l <= x) & (x < r) THEN + IF u.box.rpos = -1 THEN col := v.defAttr.color + ELSIF srd = NIL THEN + st := v.ThisSetter(); + srd := v.cachedRd; v.cachedRd := NIL; + srd := st.NewReader(srd); + srd.Set(srd.r, v.text, 0, 0, v.defRuler, 0, st.vw, st.hideMarks); rd := srd.r; + rd.SetPos(u.box.rpos); rd.Read; col := rd.attr.color + END; + f.DrawLine(x, t, x, b - f.dot, 0, col) + END + END; + INC(i) + END; + IF srd # NIL THEN CacheReader(v, srd) END + END + END DrawDecorations; + + + (* focus-message handling *) + + PROCEDURE PollSection (v: StdView; f: Views.Frame; VAR msg: Controllers.PollSectionMsg); + CONST ms = maxScrollSteps; mh = maxScrollHeight; + VAR t: Line; steps, step: INTEGER; + BEGIN + IF msg.vertical THEN + ValidateLines(v, f.b); t := v.trailer.next; + IF t.h > 0 THEN + steps := -((-t.h) DIV mh); step := -(v.dy DIV mh) + ELSE steps := 1; step := 0 + END; + msg.wholeSize := v.text.Length() * ms; + msg.partPos := v.org * ms + t.box.len * ms * step DIV steps; + msg.partSize := 0; + msg.valid := (v.org > 0) OR (t.h > mh) OR (t.next # v.trailer); + msg.done := TRUE + END + END PollSection; + + PROCEDURE Scroll (v: StdView; f: Views.Frame; VAR msg: Controllers.ScrollMsg); + VAR st: TextSetters.Setter; box, box0: TextSetters.LineBox; + t, t1, trailer: Line; org, len, dy, h, h1, sh, steps, step: INTEGER; + poll: Controllers.PollSectionMsg; + BEGIN + IF msg.vertical THEN + poll.vertical := TRUE; + PollSection(v, f, poll) + END; + IF msg.vertical & poll.valid THEN + org := v.org; dy := v.dy; st := v.ThisSetter(); trailer := v.trailer; + CASE msg.op OF + Controllers.decLine: + IF dy <= -(maxScrollHeight + fuseScrollHeight) THEN + INC(dy, maxScrollHeight) + ELSIF dy < 0 THEN + dy := 0 + ELSIF org > 0 THEN + org := st.PreviousLine(org); st.GetLine(org, box); + h1 := box.asc + box.dsc + st.GridOffset(-1, box); + IF h1 > maxScrollHeight + fuseScrollHeight THEN + sh := h1 - h1 MOD maxScrollHeight; + IF h1 - sh < fuseScrollHeight THEN DEC(sh, maxScrollHeight) END; + dy := -sh + ELSE dy := 0 + END + END + | Controllers.incLine: + t := trailer.next; + IF t.h + dy > maxScrollHeight + fuseScrollHeight THEN + DEC(dy, maxScrollHeight) + ELSIF ~t.box.eot THEN + org := t.next.start; dy := 0 + END + | Controllers.decPage: + sh := f.b; DEC(sh, maxScrollHeight + sh MOD maxScrollHeight); + IF dy <= -(sh + fuseScrollHeight) THEN + INC(dy, sh) + ELSE + t := trailer.next; + h := maxScrollHeight - dy; + IF t.h < h THEN h := t.h END; + box0 := t.box; h1:= h - st.GridOffset(-1, box0); + WHILE (org > 0) & (h + fuseScrollHeight < f.b) DO + org := st.PreviousLine(org); st.GetLine(org, box); + h1 := box.asc + box.dsc; + INC(h, h1 + st.GridOffset(box.dsc, box0)); + box0 := box + END; + h1 := h1 + st.GridOffset(-1, box0); + sh := h1 - (h - f.b); DEC(sh, sh MOD maxScrollHeight); + IF h1 - sh >= fuseScrollHeight THEN dy := -sh ELSE dy := 0 END + END; + IF (org > v.org) OR (org = v.org) & (dy <= v.dy) THEN (* guarantee progress *) + org := st.PreviousLine(org); st.GetLine(org, box); + h1 := box.asc + box.dsc + st.GridOffset(-1, box); + IF h1 > maxScrollHeight + fuseScrollHeight THEN + dy := - (h1 DIV maxScrollHeight * maxScrollHeight) + ELSE + dy := 0 + END + END + | Controllers.incPage: + t := trailer.next; + sh := f.b; DEC(sh, maxScrollHeight + sh MOD maxScrollHeight); + IF t.h + dy > sh + fuseScrollHeight THEN + DEC(dy, sh) + ELSE + t := ThisViewLine(v, f.b); LocateThisLine(v, t.start, t1, h); + IF (h + t.h >= f.b) & (t.h <= maxScrollHeight) THEN + org := st.PreviousLine(t.start) + ELSE org := t.start + END; + IF h + t.h - f.b > maxScrollHeight THEN + sh := f.b - h; DEC(sh, maxScrollHeight + sh MOD maxScrollHeight); + IF sh >= fuseScrollHeight THEN dy := -sh ELSE dy := 0 END + ELSE + dy := 0 + END + END; + IF (org < v.org) OR (org = v.org) & (dy >= v.dy) THEN (* guarantee progress *) + IF t.h + dy > maxScrollHeight + fuseScrollHeight THEN + DEC(dy, maxScrollHeight) + ELSE + org := t.next.start; dy := 0 + END + END + | Controllers.gotoPos: + org := st.ThisLine(msg.pos DIV maxScrollSteps); st.GetLine(org, box); + sh := box.asc + box.dsc + st.GridOffset(-1, box); + steps := -((-sh) DIV maxScrollHeight); + IF (steps > 0) & (box.len > 0) THEN + step := steps * (msg.pos - org * maxScrollSteps) DIV (maxScrollSteps * box.len); +(* + step := steps * (msg.pos MOD maxScrollSteps) DIV maxScrollSteps; +*) + dy := -(step * maxScrollHeight) + ELSE + dy := 0 + END + ELSE + END; + len := v.text.Length(); + IF org > len THEN org := len; dy := 0 END; + v.SetOrigin(org, dy); + msg.done := TRUE + END + END Scroll; + + PROCEDURE NotifyViewsOnPage (v: StdView; beg, end, pageNo: INTEGER); + VAR st: TextSetters.Setter; rd: TextSetters.Reader; r: TextModels.Reader; + view: Views.View; current: INTEGER; + page: PageMsg; + BEGIN + IF pageNo >= 0 THEN current := pageNo + ELSIF Printing.par # NIL THEN current := Printing.Current() (* Printing.par.page.current *) + 1 + ELSE current := -1 + END; + IF current >= 0 THEN + st := v.ThisSetter(); + rd := v.cachedRd; v.cachedRd := NIL; (* reader recycling *) + rd := st.NewReader(rd); + rd.Set(rd.r, v.text, 0, 0, v.defRuler, 0, st.vw, st.hideMarks); + r := rd.r; r.SetPos(beg); r.ReadView(view); + WHILE (r.Pos() <= end) & ~r.eot DO + page.current := current; Views.HandlePropMsg(view, page); r.ReadView(view) + END; + CacheReader(v, rd) + END + END NotifyViewsOnPage; + + PROCEDURE Page (v: StdView; pageH: INTEGER; op, pageY: INTEGER; OUT done, eoy: BOOLEAN); + VAR st: TextSetters.Setter; org, prev, page: INTEGER; + BEGIN + IF ~v.hideMarks & ((v.context = NIL) OR v.context.Normalize()) THEN + v.DisplayMarks(hide) + END; + st := v.ThisSetter(); + IF op = Controllers.nextPageY THEN + done := TRUE; org := st.NextPage(pageH, v.org); eoy := (org = v.text.Length()); + IF ~eoy THEN NotifyViewsOnPage(v, org, st.NextPage(pageH, org), -1) END + ELSIF op = Controllers.gotoPageY THEN + ASSERT(pageY >= 0, 20); + done := TRUE; org := 0; eoy := FALSE; page := 0; + WHILE (page < pageY) & ~eoy DO + prev := org; org := st.NextPage(pageH, org); eoy := org = prev; + IF ~eoy THEN NotifyViewsOnPage(v, prev, org, page) END; + INC(page) + END; + IF ~eoy THEN NotifyViewsOnPage(v, org, st.NextPage(pageH, org), page) END + ELSE + done := FALSE + END; + IF done & ~eoy THEN v.org := org; v.dy := 0; v.trailer := NIL; v.bot := 0 END + END Page; + + + PROCEDURE ShowAdjusted (v: StdView; shift: INTEGER; rebuild: BOOLEAN); + BEGIN + IF shift # 0 THEN Views.Scroll(v, 0, shift) + ELSIF rebuild THEN UpdateIn(v, 0, 0, MAX(INTEGER)) + END; + Views.RestoreDomain(v.Domain()) + END ShowAdjusted; + + PROCEDURE AdjustLines (v: StdView; org, dy: INTEGER; + OUT shift: INTEGER; OUT rebuild: BOOLEAN + ); + (* post: shift = 0 OR ~rebuild *) + VAR d: Stores.Domain; c: Containers.Controller; t, t0, t1: Line; org0, dy0, y: INTEGER; + BEGIN + d := v.Domain(); t0 := v.trailer; org0 := v.org; rebuild := FALSE; shift := 0; + IF (d # NIL) & ((org # org0) OR (dy # v.dy)) THEN + Views.RestoreDomain(d); (* make sure that pixels are up-to-date before scrolling *) + c := v.ThisController(); + IF c # NIL THEN + Containers.FadeMarks(c, Containers.hide) (* fade marks with overhang *) + END + END; + IF (t0 # NIL) & (org = org0) & (dy # v.dy) THEN (* sub-line shift *) + shift := dy - v.dy; + ELSIF (t0 # NIL) & (org > org0) & (org < t0.start) THEN (* shift up *) + LocateThisLine(v, org, t, y); t0.next := t; + shift := dy - y + ELSIF (t0 # NIL) & (org < org0) THEN (* shift down *) + t1 := t0.next; dy0 := v.dy + t1.asc; v.org := org; v.dy := dy; + IF t1.start = org0 THEN (* new lines need to be prepended *) + PrependLines(v) (* may change t1.asc *) + END; + ASSERT(t0.next.start = org, 100); + IF org0 < t0.start THEN (* former top still visible -> shift down *) + LocateThisLine(v, org0, t, y); shift := y - (dy0 - t1.asc) + ELSE (* rebuild all *) + rebuild := TRUE + END + ELSIF (t0 = NIL) OR (org # org0) OR (dy # v.dy) THEN (* rebuild all *) + rebuild := TRUE + END; + v.org := org; v.dy := dy; + IF rebuild THEN (* rebuild all *) + v.trailer := NIL; ValidateLines(v, v.bot) + ELSIF shift < 0 THEN (* shift up *) + INC(v.bot, shift); ExtendLines(v, v.bot - shift) + ELSIF shift > 0 THEN (* shift down *) + INC(v.bot, shift); ReduceLines(v, v.bot - shift) + END + END AdjustLines; + + PROCEDURE Limit (v: StdView; bot: INTEGER; allLines: BOOLEAN): INTEGER; + CONST minH = 12 * point; + VAR s, t: Line; pos, y: INTEGER; + BEGIN + s := v.trailer.next; t := s; y := v.dy; + WHILE ~t.box.eot & (y + t.h <= bot) DO INC(y, t.h); s := t; t := t.next END; + IF ~allLines & (bot - y < t.h) & (bot - y < minH) THEN t := s END; + pos := t.start + t.box.len; +(* + IF t.box.eot THEN INC(pos) END; +*) + RETURN pos + END Limit; + + + (* ScrollOp *) + + PROCEDURE (op: ScrollOp) Do; + VAR org0, dy0, org, dy, shift: INTEGER; rebuild: BOOLEAN; + BEGIN + IF op.bunch THEN org := op.bunchOrg; dy := op.bunchDy + ELSE org := op.org; dy := op.dy + END; + org0 := op.v.org; dy0 := op.v.dy; + IF op.silent THEN + op.v.org := org; op.v.dy := dy; op.silent := FALSE + ELSE + AdjustLines(op.v, org, dy, shift, rebuild); ShowAdjusted(op.v, shift, rebuild) + END; + IF op.bunch THEN op.bunch := FALSE ELSE op.org := org0; op.dy := dy0 END + END Do; + + PROCEDURE DoSetOrigin (v: StdView; org, dy: INTEGER; silent: BOOLEAN); + (* pre: org = v.ThisSetter().ThisLine(org) *) + VAR con: Models.Context; last: Stores.Operation; op: ScrollOp; + shift: INTEGER; rebuild: BOOLEAN; + BEGIN + IF (org # v.org) OR (dy # v.dy) THEN + con := v.context; + IF con # NIL THEN + IF (v.Domain() = NIL) OR con.Normalize() THEN + IF silent THEN + v.org := org; v.dy := dy + ELSE + AdjustLines(v, org, dy, shift, rebuild); ShowAdjusted(v, shift, rebuild) + END + ELSE + last := Views.LastOp(v); + IF (last # NIL) & (last IS ScrollOp) THEN + op := last(ScrollOp); + op.bunch := TRUE; op.bunchOrg := org; op.bunchDy := dy; + op.silent := silent; + Views.Bunch(v) + ELSE + NEW(op); op.v := v; op.org := org; op.dy := dy; + op.bunch := FALSE; + op.silent := silent; + Views.Do(v, scrollingKey, op) + END + END + ELSE + v.org := org; v.dy := dy + END + END + END DoSetOrigin; + + + (* SetOp *) + + PROCEDURE (op: SetOp) Do; + VAR v: StdView; m: BOOLEAN; + a: TextModels.Attributes; r: TextRulers.Ruler; s: TextSetters.Setter; + BEGIN + v := op.view; + CASE op.mode OF + setMarks: + m := v.hideMarks; v.hideMarks := op.hideMarks; op.hideMarks := m + | setSetter: + s := v.setter; + IF s # NIL THEN s.ConnectTo(NIL, NIL, 0, FALSE) END; + v.setter := op.setter; op.setter := s + | setDefs: + r := v.defRuler; a := v.defAttr; + v.defRuler := op.defRuler; v.defAttr := op.defAttr; + op.defRuler := r; op.defAttr := a; +(* + IF (v.defAttr.Domain() # NIL) & (v.defAttr.Domain() # v.Domain()) THEN + v.defAttr := Stores.CopyOf(v.defAttr)(TextModels.Attributes) + END; + Stores.Join(v, v.defAttr); +*) + IF v.defAttr # NIL THEN (* could be for undo operations *) + IF ~Stores.Joined(v, v.defAttr) THEN + IF ~Stores.Unattached(v.defAttr) THEN + v.defAttr := Stores.CopyOf(v.defAttr)(TextModels.Attributes) + END; + Stores.Join(v, v.defAttr) + END; + END; + + IF v.defRuler # NIL THEN Stores.Join(v, v.defRuler) END; + END; + RebuildView(v) + END Do; + + PROCEDURE DoSet (op: SetOp; mode: INTEGER; v: StdView); + BEGIN + op.mode := mode; op.view := v; Views.Do(v, viewSettingKey, op) + END DoSet; + + + (* StdView *) + + PROCEDURE (v: StdView) Internalize2 (VAR rd: Stores.Reader); + VAR st: Stores.Store; r: TextRulers.Ruler; a: TextModels.Attributes; + org, dy: INTEGER; thisVersion: INTEGER; hideMarks: BOOLEAN; + BEGIN + v.Internalize2^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadBool(hideMarks); + rd.ReadStore(st); ASSERT(st # NIL, 100); + IF ~(st IS TextRulers.Ruler) THEN + rd.TurnIntoAlien(Stores.alienComponent); + Stores.Report("#Text:AlienDefaultRuler", "", "", ""); + RETURN + END; + r := st(TextRulers.Ruler); + TextModels.ReadAttr(rd, a); + rd.ReadInt(org); rd.ReadInt(dy); + v.DisplayMarks(hideMarks); + v.setter := TextSetters.dir.New(); v.setter0 := NIL; + v.SetDefaults(r, a); v.SetOrigin(org, dy); + v.trailer := NIL; v.bot := 0 + END Internalize2; + + PROCEDURE (v: StdView) Externalize2 (VAR wr: Stores.Writer); + VAR org, dy: INTEGER; hideMarks: BOOLEAN; + a: Stores.Store; + BEGIN + v.Externalize2^(wr); + IF (v.context = NIL) OR v.context.Normalize() THEN + org := 0; dy := 0; hideMarks := TRUE + ELSE + org := v.org; dy := v.dy; hideMarks := v.hideMarks + END; + wr.WriteVersion(maxStdVersion); + wr.WriteBool(hideMarks); + a := Stores.CopyOf(v.defAttr); (*Stores.InitDomain(a, v.Domain());*) Stores.Join(v, a); + (* bkwd-comp hack: avoid link => so that pre release 1.3 Internalize can still read texts *) + wr.WriteStore(v.defRuler); + wr.WriteStore(a); + wr.WriteInt(org); wr.WriteInt(dy) + END Externalize2; + + PROCEDURE (v: StdView) CopyFromModelView2 (source: Views.View; model: Models.Model); + VAR s: TextSetters.Setter; r: TextRulers.Ruler; + BEGIN + (* v.CopyFromModelView^(source, model); *) + WITH source: StdView DO + s := Stores.CopyOf(source.setter)(TextSetters.Setter); + v.setter := s; v.setter0 := NIL; + r := TextRulers.CopyOf(source.defRuler, Views.deep); + v.DisplayMarks(source.HidesMarks()); + v.SetDefaults(r, source.defAttr); + v.trailer := NIL; v.bot := 0; + IF v.text = source.text THEN + v.org := source.org; v.dy := source.dy + END + END + END CopyFromModelView2; + + PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + VAR st: TextSetters.Setter; u0, u: Line; + y0, y, w, h: INTEGER; end: INTEGER; pageF: BOOLEAN; + BEGIN + ASSERT(v.context # NIL, 20); + IF v.setter # NIL THEN v.context.GetSize(w, h) END; + IF (v.setter = NIL) OR (v.setter.vw # w) THEN + Views.RemoveFrames(f, l, t, r, b) + END; + ValidateLines(v, b); + u := v.trailer.next; y := v.dy; + pageF := Views.IsPrinterFrame(f) & v.context.Normalize(); + IF pageF THEN (* on page-formatted frames do not display truncated lines at bottom *) + st := v.ThisSetter(); end := st.NextPage(f.b - f.t, v.org) + END; + WHILE (u # v.trailer) & (y + u.h <= t) DO INC(y, u.h); u := u.next END; + y0 := y; u0 := u; + IF (u = v.trailer.next) & (y < b) THEN (* at least one line per page *) + ASSERT((u.box.len > 0) OR u.box.eot OR (u.next = v.trailer), 100); + DrawLine(v, u.start, u.box, f, l, r, y + u.asc, y + u.h - u.box.dsc - u.box.asc, pageF); + INC(y, u.h); u := u.next + END; + WHILE (u # v.trailer) & (y < b) & (~pageF OR (u.start < end)) DO + ASSERT((u.box.len > 0) OR u.box.eot OR (u.next = v.trailer), 101); + IF u.box.ruler # u0.box.ruler THEN + DrawDecorations(v, u0, f, l, y0, r, y); u0 := u; y0 := y + END; + DrawLine(v, u.start, u.box, f, l, r, y + u.asc, y + u.h - u.box.dsc - u.box.asc, pageF); + INC(y, u.h); u := u.next + END; + IF y0 # y THEN DrawDecorations(v, u0, f, l, y0, r, y) END + END Restore; + + PROCEDURE (v: StdView) DisplayMarks (hide: BOOLEAN); + VAR op: SetOp; c: Containers.Controller; + BEGIN + IF v.hideMarks # hide THEN + c := v.ThisController(); + IF c # NIL THEN Containers.FadeMarks(c, Containers.hide) END; + IF (v.context # NIL) & ~v.context.Normalize() THEN + NEW(op); op.hideMarks := hide; DoSet(op, setMarks, v) + ELSE + v.hideMarks := hide; RebuildView(v) + END + END + END DisplayMarks; + + PROCEDURE (v: StdView) HidesMarks (): BOOLEAN; + BEGIN + RETURN v.hideMarks + END HidesMarks; + + PROCEDURE (v: StdView) SetSetter (setter: TextSetters.Setter); + VAR op: SetOp; + BEGIN + ASSERT(setter # NIL, 20); + IF v.setter # setter THEN + IF v.setter # NIL THEN + NEW(op); op.setter := setter; DoSet(op, setSetter, v) + ELSE v.setter := setter + END + END + END SetSetter; + + PROCEDURE (v: StdView) ThisSetter (): TextSetters.Setter; + VAR st: TextSetters.Setter; w, h: INTEGER; + BEGIN + st := v.setter; ASSERT(st # NIL, 20); + IF st # v.setter0 THEN + IF v.context # NIL THEN + v.context.GetSize(w, h) + ELSE + IF Dialog.metricSystem THEN + w := 165*mm + ELSE + w := 104*inch16 + END + END; + st.ConnectTo(v.text, v.defRuler, w, v.hideMarks); + v.setter0 := st + END; + RETURN st + END ThisSetter; + + PROCEDURE (d: StdView) AcceptableModel (m: Containers.Model): BOOLEAN; + BEGIN + RETURN m IS TextModels.Model + END AcceptableModel; + + PROCEDURE (v: StdView) InitModel2 (m: Containers.Model); + BEGIN + ASSERT(m IS TextModels.Model, 23); + v.text := m(TextModels.Model) + END InitModel2; + + PROCEDURE (v: StdView) SetOrigin (org, dy: INTEGER); + VAR st: TextSetters.Setter; start: INTEGER; + BEGIN + ASSERT(v.text # NIL, 20); + st := v.ThisSetter(); start := st.ThisLine(org); + IF start # org THEN org := start; dy := 0 END; + DoSetOrigin(v, org, dy, FALSE) + END SetOrigin; + + PROCEDURE (v: StdView) PollOrigin (OUT org, dy: INTEGER); + BEGIN + org := v.org; dy := v.dy + END PollOrigin; + + PROCEDURE (v: StdView) SetDefaults (r: TextRulers.Ruler; a: TextModels.Attributes); + VAR op: SetOp; + BEGIN + ASSERT(r # NIL, 20); ASSERT(r.style.attr.init, 21); + ASSERT(a # NIL, 22); ASSERT(a.init, 23); + IF (v.defRuler # r) OR (v.defAttr # a) THEN +(* + (*IF (v.context # NIL) & (r # v.defRuler) THEN*) + IF (v.Domain() # NIL) & (r # v.defRuler) THEN + Stores.InitDomain(r, v.Domain()) + END; +*) + IF r # v.defRuler THEN Stores.Join(v, r) END; + NEW(op); op.defRuler := r; op.defAttr := a; DoSet(op, setDefs, v) + END + END SetDefaults; + + PROCEDURE (v: StdView) PollDefaults (OUT r: TextRulers.Ruler; OUT a: TextModels.Attributes); + BEGIN + r := v.defRuler; a := v.defAttr + END PollDefaults; + +(* + PROCEDURE (v: StdView) PropagateDomain; + VAR m: Models.Model; + BEGIN + ASSERT(v.setter # NIL, 20); ASSERT(v.text # NIL, 21); + ASSERT(v.defRuler # NIL, 22); ASSERT(v.defAttr # NIL, 23); + v.PropagateDomain^; + m := v.ThisModel(); + IF m # NIL THEN Stores.InitDomain(m, v.Domain()) END; + Stores.InitDomain(v.defRuler, v.Domain()) + END PropagateDomain; + *) +(* + PROCEDURE (v: StdView) Flush, NEW; + BEGIN + v.trailer := NIL; v.bot := 0; v.setter0 := NIL + END Flush; +*) + PROCEDURE (v: StdView) HandleModelMsg2 (VAR msg: Models.Message); + BEGIN + IF msg.model = v.text THEN + WITH msg: Models.UpdateMsg DO + WITH msg: TextModels.UpdateMsg DO + IF msg.op IN {TextModels.insert, TextModels.delete, TextModels.replace} THEN + UpdateView(v, msg.beg, msg.end, msg.delta) + ELSE (* unknown text op happened *) + RebuildView(v) + END + ELSE (* unknown text update happened *) + RebuildView(v) + END + | msg: PositionMsg DO + v.ShowRange(msg.beg, msg.end, msg.focusOnly) + ELSE + END + ELSE (* domaincast received *) + WITH msg: TextRulers.UpdateMsg DO + StyleUpdate(v, msg.oldAttr) + | msg: Models.UpdateMsg DO (* forced rebuild *) + RebuildView(v) + ELSE + END + END + END HandleModelMsg2; + + PROCEDURE (v: StdView) HandleViewMsg2 (f: Views.Frame; VAR msg: Views.Message); + BEGIN + IF msg.view = v THEN + WITH msg: FindAnyFrameMsg DO + IF (msg.frame = NIL) OR (msg.frame.b - msg.frame.t > f.b - f.t) THEN msg.frame := f END + ELSE + END + ELSE + WITH msg: Views.UpdateCachesMsg DO (* display view in new frame *) + IF Views.Era(v) # Models.Era(v.text) THEN + (* view/setter caches outdated - possible if v previous to this notification had no frame open *) + v.setter0 := NIL; v.trailer := NIL; v.bot := 0 + END + ELSE + END + END + END HandleViewMsg2; + + PROCEDURE (v: StdView) HandleCtrlMsg2 (f: Views.Frame; + VAR msg: Controllers.Message; VAR focus: Views.View + ); + BEGIN + WITH msg: Controllers.PollSectionMsg DO + IF (focus = NIL) OR ~msg.focus THEN + PollSection(v, f, msg); + focus := NIL + END + | msg: FindFocusFrameMsg DO + IF (msg.view = v) & (msg.frame = NIL) THEN msg.frame := f END + | msg: Controllers.ScrollMsg DO + IF (focus = NIL) OR ~msg.focus THEN + Scroll(v, f, msg); + focus := NIL + END + | msg: Controllers.PageMsg DO + Page(v, f.b - f.t, msg.op, msg.pageY, msg.done, msg.eoy); + focus := NIL + ELSE + END + END HandleCtrlMsg2; + + PROCEDURE (v: StdView) HandlePropMsg2 (VAR p: Properties.Message); + CONST minW = 5 * point; maxW = maxHeight; minH = 5 * point; maxH = maxHeight; + VAR st: TextSetters.Setter; + BEGIN + WITH p: Properties.SizePref DO + IF p.w = Views.undefined THEN p.w := v.defRuler.style.attr.right END; + IF p.h = Views.undefined THEN p.h := MAX(INTEGER) END + | p: Properties.BoundsPref DO + st := v.ThisSetter(); + st.GetBox(0, v.text.Length(), maxW, maxH, p.w, p.h); + IF p.w < minW THEN p.w := minW END; + IF p.h < minH THEN p.h := minH END + | p: Properties.ResizePref DO + p.fixed := FALSE; + p.horFitToPage := ~(TextRulers.rightFixed IN v.defRuler.style.attr.opts); + p.verFitToWin := TRUE + | p: Properties.TypePref DO + IF Services.Is(v, p.type) THEN p.view := v END + | p: Containers.DropPref DO + p.okToDrop := TRUE + ELSE + END + END HandlePropMsg2; + + + PROCEDURE (v: StdView) GetThisLocation (f: Views.Frame; pos: INTEGER; OUT loc: Location); + (* pre: f must be displayed *) + (* if position lies outside view, the next best location inside will be taken *) + VAR rd: TextSetters.Reader; t: Line; p1, y, w, h: INTEGER; + BEGIN + ValidateLines(v, f.b); + y := v.dy; + IF pos < v.org THEN + t := v.trailer.next; + loc.start := t.start; loc.pos := t.start; + loc.x := 0; loc.y := y; loc.asc := t.asc; loc.dsc := t.h - t.asc; loc.view := NIL; + RETURN + ELSIF pos < v.trailer.start THEN + t := v.trailer.next; + WHILE ~t.box.eot & ~((t.start <= pos) & (pos < t.next.start)) DO + INC(y, t.h); t := t.next + END + ELSE (* pos >= v.trailer.start *) + t := v.trailer.next; WHILE ~t.box.eot DO INC(y, t.h); t := t.next END; + IF t = v.trailer THEN + loc.start := t.start; loc.pos := t.start; + loc.x := 0; loc.y := y; loc.asc := t.asc; loc.dsc := t.h - t.asc; loc.view := NIL; + RETURN + END + END; + p1 := t.start; + rd := GetReader(v, p1, t.box); rd.Read; + WHILE rd.pos < pos DO + p1 := rd.pos; rd.AdjustWidth(t.start, p1, t.box, rd.w); INC(rd.x, rd.w); rd.Read + END; + IF LEN(rd.string$) > 1 THEN (* collated subsequence *) + rd.x := f.CharPos(rd.x, pos - p1, rd.string, rd.attr.font); + IF rd.pos = pos THEN rd.Read END + ELSIF rd.pos = pos THEN + rd.AdjustWidth(t.start, pos, t.box, rd.w); INC(rd.x, rd.w); rd.Read + ELSE + ASSERT(p1 = pos, 100) + END; + loc.view := rd.view; + loc.start := t.start; loc.pos := pos; + loc.x := rd.x; loc.y := y; loc.asc := t.asc; loc.dsc := t.h - t.asc; + IF loc.view # NIL THEN + v.context.GetSize(w, h); + IF rd.x + rd.w > w THEN rd.w := w - rd.x END; + loc.l := rd.x; loc.t := y - rd.attr.offset + t.asc + rd.dsc - rd.h; + loc.r := loc.l + rd.w; loc.b := loc.t + rd.h + END; + CacheReader(v, rd) + END GetThisLocation; + + PROCEDURE (v: StdView) GetRange (f: Views.Frame; OUT beg, end: INTEGER); + VAR t: Line; + BEGIN + ValidateLines(v, f.b); + t := ThisViewLine(v, f.t); beg := t.start; end := Limit(v, f.b, TRUE) + END GetRange; + + PROCEDURE (v: StdView) ThisPos (f: Views.Frame; x, y: INTEGER): INTEGER; + (* pre: f must be displayed *) + (* post: f.org <= result <= v.text.Length() *) + VAR rd: TextSetters.Reader; t: Line; p1, end, py: INTEGER; + BEGIN + ValidateLines(v, f.b); + t := v.trailer.next; py := v.dy; + WHILE ~t.box.eot & (py + t.h <= y) DO INC(py, t.h); t := t.next END; + p1 := t.start; end := p1 + t.box.len; + IF py + t.h > y THEN + IF (end > p1) & (y >= v.dy) THEN + IF t.box.eot THEN INC(end) END; + rd := GetReader(v, p1, t.box); + rd.Read; rd.AdjustWidth(t.start, rd.pos, t.box, rd.w); + WHILE (rd.x + rd.SplitWidth(rd.w) < x) & (rd.pos < end) DO + p1 := rd.pos; INC(rd.x, rd.w); + rd.Read; rd.AdjustWidth(t.start, rd.pos, t.box, rd.w) + END; + IF LEN(rd.string$) > 1 THEN (* collated subsequence *) + INC(p1, f.CharIndex(rd.x, x, rd.string, rd.attr.font)) + END; + CacheReader(v, rd) + END + ELSE p1 := end + END; + RETURN p1 + END ThisPos; + + PROCEDURE (v: StdView) ShowRangeIn (f: Views.Frame; beg, end: INTEGER); + CONST minH = 12 * point; + VAR c: Models.Context; st: TextSetters.Setter; t, t1: Line; + org0, last, len, org, dy, p, q: INTEGER; y, h, mh: INTEGER; + box, box0: TextSetters.LineBox; loc, loc1: Location; + focus: BOOLEAN; + BEGIN + focus := f = Controllers.FocusFrame(); + c := v.context; + st := v.ThisSetter(); ValidateLines(v, f.b); org0 := v.org; + last := Limit(v, f.b, FALSE); len := v.text.Length(); + IF last = len THEN p := st.ThisLine(last); LocateThisLine(v, p, t1, y); h := f.b - y END; + IF (beg > last) + OR (beg = last) & ((last < len) OR (len > 0) & (h < t1.h) & (h < minH)) + OR (end < org0) + OR (beg < end) & (end = org0) THEN + org := -1; dy := 0; + IF beg <= org0 THEN (* try to adjust by scrolling up *) + p := st.PreviousLine(v.org); + IF p <= beg THEN (* reveal one line at top *) + org := p; st.GetLine(org, box); + h := box.asc + box.dsc + st.GridOffset(-1, box); + IF h > maxScrollHeight + fuseScrollHeight THEN + dy := -(h - h MOD maxScrollHeight); + IF h + dy < fuseScrollHeight THEN INC(dy, maxScrollHeight) END + END + END + END; + IF (org = -1) & (beg >= last) THEN (* try to adjust by scrolling down *) + p := st.ThisLine(last); q := st.NextLine(p); st.GetLine(q, box); + IF (beg < q + box.len) OR (p = q) THEN (* reveal one line at bottom *) + LocateThisLine(v, p, t1, y); + h := box.asc + box.dsc + st.GridOffset(t1.box.dsc, box); + IF h > maxScrollHeight + fuseScrollHeight THEN h := maxScrollHeight END; + mh := y + t1.h - f.b + h; + t := v.trailer.next; h := v.dy; + WHILE (t # v.trailer) & (h < mh) DO INC(h, t.h); t := t.next END; + IF t.start > v.org THEN org := t.start END + END + END; + IF org = -1 THEN (* adjust by moving into "nice" position *) + mh := f.b DIV 3; + org := st.ThisLine(beg); st.GetLine(org, box0); + h := box0.asc + box0.dsc + st.GridOffset(-1, box0); p := org; + WHILE (p > 0) & (h < mh) DO + DEC(h, st.GridOffset(-1, box0)); org := p; + p := st.PreviousLine(org); st.GetLine(p, box); + INC(h, box.asc + box.dsc + st.GridOffset(box.dsc, box0)); + box0 := box + END; + IF (org = len) & (len > 0) THEN org := st.PreviousLine(org) END + END; + DoSetOrigin(v, org, dy, FALSE) + END; + IF focus THEN + f := Controllers.FocusFrame(); + IF (f # NIL) & (f.view = v) THEN + + v.GetThisLocation(f, beg, loc); + v.GetThisLocation(f, end, loc1); + IF (loc.y = loc1.y) & (loc.x <= loc1.x) THEN + c.MakeVisible(loc.x, loc.y, loc1.x, loc1.y) + END + ELSE + HALT(100); (* this should not happen *) + END + END; +(* + IF c IS Documents.Context THEN + v.GetThisLocation(f, beg, loc); + v.GetThisLocation(f, end, loc1); + IF (loc.y = loc1.y) & (loc.x <= loc1.x) THEN + Documents.MakeVisible(c(Documents.Context).ThisDoc(), f, loc.x, loc.y, loc1.x, loc1.y) + END + END +*) + END ShowRangeIn; + + PROCEDURE (v: StdView) ShowRange (beg, end: INTEGER; focusOnly: BOOLEAN); + VAR fmsg: FindFocusFrameMsg; amsg: FindAnyFrameMsg; f: Views.Frame; + BEGIN + IF focusOnly THEN + fmsg.view := v; fmsg.frame := NIL; Controllers.Forward(fmsg); f := fmsg.frame + ELSE + amsg.frame := NIL; Views.Broadcast(v, amsg); f := amsg.frame + END; + IF f # NIL THEN v.ShowRangeIn(f, beg, end) END + END ShowRange; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (text: TextModels.Model): View; + VAR v: StdView; c: Controllers.Controller; r: TextRulers.Ruler; + BEGIN + r := TextRulers.dir.New(NIL); + IF text = NIL THEN text := TextModels.dir.New() END; + (* IF text.Domain() # NIL THEN Stores.InitDomain(r, text.Domain()) END; *) + Stores.Join(text, r); + NEW(v); v.hideMarks := FALSE; v.bot := 0; v.org := 0; v.dy := 0; + v.InitModel(text); + v.SetDefaults(r, d.defAttr); + v.SetSetter(TextSetters.dir.New()); + v.DisplayMarks(hide); + IF ctrlDir # NIL THEN v.SetController(ctrlDir.New()) END; + (* Stores.InitDomain(v, text.Domain()); *) + Stores.Join(v, text); + RETURN v + END New; + + + PROCEDURE Init; + VAR d: StdDirectory; a: TextModels.Attributes; res: INTEGER; + BEGIN + Dialog.Call("TextControllers.Install", "#Text:CntrlInstallFailed", res); + NEW(a); a.InitFromProp(NIL); (* use defaults *) + NEW(d); d.defAttr := a; + stdDir := d; dir := d + END Init; + +BEGIN + Init +END TextViews. diff --git a/Trurl-based/Text/Rsrc/Cmds.odc b/Trurl-based/Text/Rsrc/Cmds.odc new file mode 100644 index 0000000..7c632a6 Binary files /dev/null and b/Trurl-based/Text/Rsrc/Cmds.odc differ diff --git a/Trurl-based/Text/Rsrc/Cmds1.odc b/Trurl-based/Text/Rsrc/Cmds1.odc new file mode 100644 index 0000000..f24561e Binary files /dev/null and b/Trurl-based/Text/Rsrc/Cmds1.odc differ diff --git a/Trurl-based/Text/Rsrc/Menus.odc b/Trurl-based/Text/Rsrc/Menus.odc new file mode 100644 index 0000000..d566eed Binary files /dev/null and b/Trurl-based/Text/Rsrc/Menus.odc differ diff --git a/Trurl-based/Text/Rsrc/Strings.odc b/Trurl-based/Text/Rsrc/Strings.odc new file mode 100644 index 0000000..5715115 Binary files /dev/null and b/Trurl-based/Text/Rsrc/Strings.odc differ diff --git a/Trurl-based/Xhtml/Docu/EntitySets.odc b/Trurl-based/Xhtml/Docu/EntitySets.odc new file mode 100644 index 0000000..2d0113c Binary files /dev/null and b/Trurl-based/Xhtml/Docu/EntitySets.odc differ diff --git a/Trurl-based/Xhtml/Docu/Exporter.odc b/Trurl-based/Xhtml/Docu/Exporter.odc new file mode 100644 index 0000000..30e0cc5 Binary files /dev/null and b/Trurl-based/Xhtml/Docu/Exporter.odc differ diff --git a/Trurl-based/Xhtml/Docu/StdFileWriters.odc b/Trurl-based/Xhtml/Docu/StdFileWriters.odc new file mode 100644 index 0000000..e5f9016 Binary files /dev/null and b/Trurl-based/Xhtml/Docu/StdFileWriters.odc differ diff --git a/Trurl-based/Xhtml/Docu/Sys-Map.odc b/Trurl-based/Xhtml/Docu/Sys-Map.odc new file mode 100644 index 0000000..b233f1a Binary files /dev/null and b/Trurl-based/Xhtml/Docu/Sys-Map.odc differ diff --git a/Trurl-based/Xhtml/Docu/TextTableMarkers.odc b/Trurl-based/Xhtml/Docu/TextTableMarkers.odc new file mode 100644 index 0000000..95cff07 Binary files /dev/null and b/Trurl-based/Xhtml/Docu/TextTableMarkers.odc differ diff --git a/Trurl-based/Xhtml/Docu/Writers.odc b/Trurl-based/Xhtml/Docu/Writers.odc new file mode 100644 index 0000000..c294e4e Binary files /dev/null and b/Trurl-based/Xhtml/Docu/Writers.odc differ diff --git a/Trurl-based/Xhtml/Mod/EntitySets.odc b/Trurl-based/Xhtml/Mod/EntitySets.odc new file mode 100644 index 0000000..987a385 Binary files /dev/null and b/Trurl-based/Xhtml/Mod/EntitySets.odc differ diff --git a/Trurl-based/Xhtml/Mod/Exporter.odc b/Trurl-based/Xhtml/Mod/Exporter.odc new file mode 100644 index 0000000..09fc65d Binary files /dev/null and b/Trurl-based/Xhtml/Mod/Exporter.odc differ diff --git a/Trurl-based/Xhtml/Mod/StdFileWriters.odc b/Trurl-based/Xhtml/Mod/StdFileWriters.odc new file mode 100644 index 0000000..186af55 Binary files /dev/null and b/Trurl-based/Xhtml/Mod/StdFileWriters.odc differ diff --git a/Trurl-based/Xhtml/Mod/TextTableMarkers.odc b/Trurl-based/Xhtml/Mod/TextTableMarkers.odc new file mode 100644 index 0000000..9f92fef Binary files /dev/null and b/Trurl-based/Xhtml/Mod/TextTableMarkers.odc differ diff --git a/Trurl-based/Xhtml/Mod/Writers.odc b/Trurl-based/Xhtml/Mod/Writers.odc new file mode 100644 index 0000000..902254c Binary files /dev/null and b/Trurl-based/Xhtml/Mod/Writers.odc differ diff --git a/Trurl-based/Xhtml/Rsrc/Strings.odc b/Trurl-based/Xhtml/Rsrc/Strings.odc new file mode 100644 index 0000000..7e5d43a Binary files /dev/null and b/Trurl-based/Xhtml/Rsrc/Strings.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.odc b/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.odc new file mode 100644 index 0000000..d99add6 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.txt b/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.txt new file mode 100644 index 0000000..c565553 --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.txt @@ -0,0 +1,121 @@ +MODULE HostLang; + + (* THIS IS TEXT COPY OF Lang.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.10 + + LANG environment variable support + Dialog.LanguageHook implementation + *) + + IMPORT Dialog, Libc := LinLibc; + + CONST + defLang = ""; + defCountry = ""; + defEnc = "ASCII"; + + TYPE + LanguageHook = POINTER TO RECORD (Dialog.LanguageHook) END; + + Country = ARRAY 3 OF SHORTCHAR; + Encoding = ARRAY 32 OF SHORTCHAR; + + VAR + lang-: Dialog.Language; + enc-: Encoding; + + PROCEDURE ParseLang (OUT lang: Dialog.Language; OUT country: Country; OUT enc: Encoding); + VAR env: Libc.PtrSTR; + i, j: INTEGER; + + PROCEDURE Default; + BEGIN + lang := defLang; + country := defCountry; + enc := defEnc + END Default; + + PROCEDURE IsValidEncChar (x: SHORTCHAR): BOOLEAN; + BEGIN + RETURN ((x >= 'A') & (x <= 'Z')) OR ((x >= '0') & (x <= '9')) OR (x = '-') OR (x = '_') + OR ((x >= 'a') & (x <= 'z')) + END IsValidEncChar; + + BEGIN + env := Libc.getenv("LANG"); + IF env # NIL THEN + IF env$ = "C" THEN + lang := ""; country := ""; enc := "ASCII" + ELSE + i := 0; + WHILE (i < 2) & (env[i] >= 'a') & (env[i] <= 'z') & (i < LEN(lang) - 1) DO + lang[i] := env[i]; + INC(i) + END; + IF (i = 2) & (env[i] = '_') & (i < LEN(lang)) THEN + lang[i] := 0X; + INC(i); + j := 0; + WHILE (i < 5) & (env[i] >= 'A') & (env[i] <= 'Z') & (j < LEN(country) - 1) DO + country[j] := env[i]; + INC(j); INC(i) + END; + IF (i = 5) & (env[i] = '.') & (j < LEN(country)) THEN + country[j] := 0X; + INC(i); + j := 0; + WHILE IsValidEncChar(env[i]) & (j < LEN(enc) - 1) DO + enc[j] := env[i]; + INC(j); INC(i) + END; + IF (env[i] = 0X) & (j < LEN(enc)) THEN + enc[j] := 0X + ELSE Default + END + ELSE Default + END + ELSE Default + END + END + ELSE Default + END + END ParseLang; + + PROCEDURE (hook: LanguageHook) SetLanguage ( + lang: Dialog.Language; persistent: BOOLEAN; OUT ok: BOOLEAN + ); + BEGIN + ok := (lang = "") OR (LEN(lang$) = 2); +(* + IF ok & persistent THEN HostRegistry.WriteString("language", lang) END +*) + END SetLanguage; + + PROCEDURE (hook: LanguageHook) GetPersistentLanguage (OUT l: Dialog.Language); + VAR res: INTEGER; s: ARRAY 32 OF CHAR; + BEGIN +(* + HostRegistry.ReadString("language", s, res); + IF res = 0 THEN + ASSERT((s = "") OR (LEN(s$) = 2), 100); + lang := s$ + ELSE lang := "" + END +*) + l := lang + END GetPersistentLanguage; + + PROCEDURE Init; + VAR languageHook: LanguageHook; + country: Country; + BEGIN + ParseLang(lang, country, enc); + NEW(languageHook); Dialog.SetLanguageHook(languageHook); Dialog.ResetLanguage + END Init; + +BEGIN + Init +END HostLang. diff --git a/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.odc b/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.odc new file mode 100644 index 0000000..55d7a2b Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.txt b/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.txt new file mode 100644 index 0000000..f539a8f --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.txt @@ -0,0 +1,1155 @@ +MODULE HostTextConv; + + (* THIS IS TEXT COPY OF TextConv.odc *) + (* DO NOT EDIT *) + + IMPORT + SYSTEM, (* WinApi, WinOle, COM, *) + Files, Fonts, Ports, Stores, Views, Properties, + HostFonts, (* HostClipboard, *) TextModels, + TextRulers, TextViews, TextMappers; + + CONST + CR = 0DX; LF = 0AX; FF = 0EX; TAB = 09X; + halfpoint = Ports.point DIV 2; + twips = Ports.point DIV 20; + + TYPE + Context = POINTER TO RECORD + next: Context; + dest: INTEGER; + uniCnt : INTEGER; + attr: TextModels.Attributes; + pattr: TextRulers.Attributes + END; + MemReader = POINTER TO RECORD (Files.Reader) + adr, pos: INTEGER + END; + + VAR + debug*: BOOLEAN; + + + (* MemReader *) + + PROCEDURE (r: MemReader) Base (): Files.File; + BEGIN + RETURN NIL + END Base; + + PROCEDURE (r: MemReader) Pos (): INTEGER; + BEGIN + RETURN r.pos + END Pos; + + PROCEDURE (r: MemReader) SetPos (pos: INTEGER); + BEGIN + r.pos := pos + END SetPos; + + PROCEDURE (r: MemReader) ReadByte (OUT x: BYTE); + BEGIN + SYSTEM.GET(r.adr + r.pos, x); INC(r.pos) + END ReadByte; + + PROCEDURE (r: MemReader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER); + BEGIN + HALT(126) + END ReadBytes; + +(* + PROCEDURE GenGlobalMedium (hg: WinApi.HGLOBAL; unk: COM.IUnknown; VAR sm: WinOle.STGMEDIUM); + BEGIN + sm.tymed := WinOle.TYMED_HGLOBAL; + sm.u.hGlobal := hg; + sm.pUnkForRelease := unk + END GenGlobalMedium; + + PROCEDURE MediumGlobal (VAR sm: WinOle.STGMEDIUM): WinApi.HGLOBAL; + BEGIN + ASSERT(sm.tymed = WinOle.TYMED_HGLOBAL, 20); + RETURN sm.u.hGlobal + END MediumGlobal; +*) + + PROCEDURE WriteWndChar (wr: TextModels.Writer; ch: CHAR); + BEGIN + CASE ch OF + | CR, TAB, " "..7EX, 0A0X..0FFX: wr.WriteChar(ch) + | LF: + | 80X: wr.WriteChar(20ACX) (* euro *) + | 82X: wr.WriteChar(201AX) + | 83X: wr.WriteChar(0192X) + | 84X: wr.WriteChar(201EX) + | 85X: wr.WriteChar(2026X) + | 86X: wr.WriteChar(2020X) + | 87X: wr.WriteChar(2021X) + | 88X: wr.WriteChar(02C6X) + | 89X: wr.WriteChar(2030X) + | 8AX: wr.WriteChar(0160X) + | 8BX: wr.WriteChar(2039X) + | 8CX: wr.WriteChar(0152X) + | 91X: wr.WriteChar(2018X) + | 92X: wr.WriteChar(2019X) + | 93X: wr.WriteChar(201CX) + | 94X: wr.WriteChar(201DX) + | 95X: wr.WriteChar(2022X) + | 96X: wr.WriteChar(2013X) + | 97X: wr.WriteChar(2014X) + | 98X: wr.WriteChar(02DCX) + | 99X: wr.WriteChar(2122X) + | 9AX: wr.WriteChar(0161X) + | 9BX: wr.WriteChar(203AX) + | 9CX: wr.WriteChar(0153X) + | 9FX: wr.WriteChar(0178X) + | 0X..8X, 0BX, 0CX, 0EX..1FX, 7FX, 81X, 8DX..90X, 9DX, 9EX: + wr.WriteChar(CHR(0EF00H + ORD(ch))) + END + END WriteWndChar; + + PROCEDURE ThisWndChar (ch: CHAR): CHAR; + BEGIN + IF ch >= 100X THEN + IF (ch >= 0EF00X) & (ch <= 0EFFFX) THEN ch := CHR(ORD(ch) - 0EF00H) + ELSIF ch = 20ACX THEN ch := 80X (* euro *) + ELSIF ch = 201AX THEN ch := 82X + ELSIF ch = 0192X THEN ch := 83X + ELSIF ch = 201EX THEN ch := 84X + ELSIF ch = 2026X THEN ch := 85X + ELSIF ch = 2020X THEN ch := 86X + ELSIF ch = 2021X THEN ch := 87X + ELSIF ch = 02C6X THEN ch := 88X + ELSIF ch = 2030X THEN ch := 89X + ELSIF ch = 0160X THEN ch := 8AX + ELSIF ch = 2039X THEN ch := 8BX + ELSIF ch = 0152X THEN ch := 8CX + ELSIF ch = 2018X THEN ch := 91X + ELSIF ch = 2019X THEN ch := 92X + ELSIF ch = 201CX THEN ch := 93X + ELSIF ch = 201DX THEN ch := 94X + ELSIF ch = 2022X THEN ch := 95X + ELSIF ch = 2013X THEN ch := 96X + ELSIF ch = 2014X THEN ch := 97X + ELSIF ch = 02DCX THEN ch := 98X + ELSIF ch = 2122X THEN ch := 99X + ELSIF ch = 0161X THEN ch := 9AX + ELSIF ch = 203AX THEN ch := 9BX + ELSIF ch = 0153X THEN ch := 9CX + ELSIF ch = 0178X THEN ch := 9FX + ELSE ch := "?" + END + ELSIF ch = 08FX THEN ch := " " (* digit space *) + END; + RETURN ch + END ThisWndChar; + + PROCEDURE ParseRichText (rd: Files.Reader; wr: TextModels.Writer; VAR defRuler: TextRulers.Ruler); + TYPE + FontInfo = POINTER TO RECORD id: INTEGER; f: Fonts.Typeface; next: FontInfo END; + ColorInfo = POINTER TO RECORD id: INTEGER; c: Ports.Color; next: ColorInfo END; + CONST text = 0; fonttab = 1; colortab = 2; skip = 3; + VAR ch: CHAR; tabStyle: SET; + fact, val, defFont, dest, idx, fnum, cnum, paraPos, i: INTEGER; + fonts, font: FontInfo; colors: ColorInfo; + hasNum, remPar, skipDest: BOOLEAN; + f: Fonts.Font; comm: ARRAY 32 OF CHAR; + c, con: Context; p0: Properties.Property; p: TextRulers.Prop; + ruler: TextRulers.Ruler; + pattr: TextRulers.Attributes; + skipCnt, uniCnt : INTEGER; + + PROCEDURE Color(i: INTEGER): ColorInfo; + VAR c: ColorInfo; + BEGIN + ASSERT(colors # NIL, 20); + c := colors; + WHILE (c # NIL) & (c.id # i) DO c := c.next END; + ASSERT(c # NIL, 100); + RETURN c + END Color; + + PROCEDURE SetColor(i: INTEGER; c: Ports.Color); + VAR ci: ColorInfo; + BEGIN + NEW(ci); ci.id := i; ci.c := c; ci.next := colors; colors := ci + END SetColor; + + PROCEDURE Font(i: INTEGER): FontInfo; + VAR f: FontInfo; + BEGIN + ASSERT(fonts # NIL, 20); + f := fonts; + WHILE (f # NIL) & (f.id # i) DO f := f.next END; + ASSERT(f # NIL, 100); + RETURN f + END Font; + + PROCEDURE SetFont(i: INTEGER; tf: Fonts.Typeface); + VAR f: FontInfo; + BEGIN + NEW(f); f.id := i; f.f := tf; f.next := fonts; fonts := f + END SetFont; + + PROCEDURE Next (VAR ch: CHAR); + VAR b: BYTE; + BEGIN + rd.ReadByte(b); ch := CHR(b MOD 256) + END Next; + + PROCEDURE Write (ch: CHAR); + BEGIN + IF skipCnt > 0 THEN + DEC(skipCnt) + ELSIF dest = text THEN + IF ch < 100X THEN WriteWndChar(wr, ch) + ELSE wr.WriteChar(ch) + END + ELSIF dest = fonttab THEN + ASSERT(font # NIL, 20); + font.f[idx] := ch; INC(idx); font.f[idx] := 0X + END + END Write; + + PROCEDURE Paragraph; + VAR v: Views.View; + BEGIN + IF ~pattr.Equals(ruler.style.attr) THEN (* new ruler needed *) + wr.SetPos(paraPos); + v := Views.CopyOf(ruler, Views.deep); ruler := v(TextRulers.Ruler); + ruler.style.SetAttr(pattr); + wr.WriteView(ruler, Views.undefined, Views.undefined); + wr.SetPos(wr.Base().Length()) + ELSIF (pattr.first # pattr.left) + OR (pattr.lead > 0) + OR (TextRulers.pageBreak IN pattr.opts) THEN (* paragraph marker needed *) + wr.SetPos(paraPos); + wr.WriteChar(FF); + wr.SetPos(wr.Base().Length()) + END; + wr.WriteChar(CR); + paraPos := wr.Pos() + END Paragraph; + + BEGIN + defFont := 0; fnum := 1; f := Fonts.dir.Default(); NEW(fonts); fonts.f := f.typeface; skipCnt := 0; uniCnt := 1; + cnum := 1; NEW(colors); SetColor(0, Ports.defaultColor); + dest := text; con := NIL; paraPos := 0; remPar := FALSE; skipDest := FALSE; + defRuler := TextRulers.dir.New(NIL); ruler := defRuler; pattr := defRuler.style.attr; tabStyle := {}; + Next(ch); + WHILE ch # 0X DO + IF ch = "{" THEN + skipCnt := 0; + NEW(c); c.dest := dest; c.attr := wr.attr; c.pattr := pattr; c.uniCnt := uniCnt; c.next := con; con := c; + Next(ch) + ELSIF ch = "}" THEN + skipCnt := 0; + IF con # NIL THEN + dest := con.dest; uniCnt := con.uniCnt; wr.SetAttr(con.attr); pattr := con.pattr; con := con.next + END; + Next(ch) + ELSIF ch = "\" THEN + Next(ch); i := 0; val := 0; + IF (ch >= "a") & (ch <= "z") THEN + WHILE (ch >= "a") & (ch <= "z") DO comm[i] := ch; INC(i); Next(ch) END; + comm[i] := 0X; fact := 1; hasNum := FALSE; + IF ch = "-" THEN fact := -1; Next(ch) END; + WHILE (ch >= "0") & (ch <= "9") DO + val := 10 * val + ORD(ch) - ORD("0"); Next(ch); hasNum := TRUE + END; + val := val * fact; + IF ch = " " THEN Next(ch) END; + (* special characters *) + IF skipCnt > 0 THEN DEC(skipCnt) (* command skipped as single character *) + ELSIF comm = "tab" THEN Write(TAB) + ELSIF comm = "line" THEN Write(CR) + ELSIF comm = "par" THEN Paragraph + ELSIF comm = "sect" THEN Paragraph + ELSIF comm = "ldblquote" THEN Write(201CX) (* unicode: left double quote *) + ELSIF comm = "rdblquote" THEN Write(201DX) (* unicode: right double quote *) + ELSIF comm = "lquote" THEN Write(2018X) (* unicode: left single quote *) + ELSIF comm = "rquote" THEN Write(2019X) (* unicode: right single quote *) + ELSIF comm = "enspace" THEN Write(2002X) (* unicode: en space *) + ELSIF comm = "emspace" THEN Write(2003X) (* unicode: em space *) + ELSIF comm = "endash" THEN Write(2013X) (* unicode: en dash *) + ELSIF comm = "emdash" THEN Write(2014X) (* unicode: em dash *) + ELSIF comm = "page" THEN + Paragraph; NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {TextRulers.pageBreak}; p.opts.mask := p.opts.val; + pattr := TextRulers.ModifiedAttr(pattr, p) + (* character attributes *) + ELSIF comm = "plain" THEN + wr.SetAttr(TextModels.NewWeight(wr.attr, Fonts.normal)); + wr.SetAttr(TextModels.NewStyle(wr.attr, {})); + wr.SetAttr(TextModels.NewTypeface(wr.attr, Font(defFont).f)); + wr.SetAttr(TextModels.NewSize(wr.attr, 24 * halfpoint)); + wr.SetAttr(TextModels.NewColor(wr.attr, Ports.defaultColor)); + wr.SetAttr(TextModels.NewOffset(wr.attr, 0)) + ELSIF comm = "b" THEN + IF hasNum & (val = 0) THEN wr.SetAttr(TextModels.NewWeight(wr.attr, Fonts.normal)) + ELSE wr.SetAttr(TextModels.NewWeight(wr.attr, Fonts.bold)) + END + ELSIF comm = "i" THEN + IF hasNum & (val = 0) THEN + wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style - {Fonts.italic})) + ELSE wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style + {Fonts.italic})) + END + ELSIF comm = "ul" THEN + IF hasNum & (val = 0) THEN + wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style - {Fonts.underline})) + ELSE wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style + {Fonts.underline})) + END + ELSIF comm = "strike" THEN + IF hasNum & (val = 0) THEN + wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style - {Fonts.strikeout})) + ELSE wr.SetAttr(TextModels.NewStyle(wr.attr, wr.attr.font.style + {Fonts.strikeout})) + END + ELSIF comm = "f" THEN + IF ~hasNum THEN val := defFont END; + IF dest = fonttab THEN + fnum := val; idx := 0; NEW(font); font.id := val; font.next := fonts; fonts := font + ELSE + wr.SetAttr(TextModels.NewTypeface(wr.attr, Font(val).f)) + END + ELSIF comm = "fs" THEN + IF ~hasNum THEN val := 24 END; + wr.SetAttr(TextModels.NewSize(wr.attr, val * halfpoint)) + ELSIF comm = "cf" THEN + wr.SetAttr(TextModels.NewColor(wr.attr, Color(val).c)) + ELSIF comm = "dn" THEN + IF ~hasNum THEN val := 6 END; + wr.SetAttr(TextModels.NewOffset(wr.attr, -(val * halfpoint))) + ELSIF comm = "up" THEN + IF ~hasNum THEN val := 6 END; + wr.SetAttr(TextModels.NewOffset(wr.attr, val * halfpoint)) + (* paragraph attributes *) + ELSIF comm = "pard" THEN + pattr := defRuler.style.attr; tabStyle := {} + ELSIF comm = "fi" THEN + NEW(p); + p.valid := {TextRulers.first}; p.first := pattr.left + val * twips; + IF p.first < 0 THEN (* change left indent to make the value legal *) + p.valid := {TextRulers.left, TextRulers.first}; + p.left := pattr.left - p.first; p.first := 0 + END; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "li" THEN + NEW(p); + p.valid := {TextRulers.left, TextRulers.first}; + p.left := val * twips; p.first := p.left + pattr.first - pattr.left; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "ql" THEN + NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {TextRulers.leftAdjust}; + p.opts.mask := {TextRulers.leftAdjust, TextRulers.rightAdjust}; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "qr" THEN + NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {TextRulers.rightAdjust}; + p.opts.mask := {TextRulers.leftAdjust, TextRulers.rightAdjust}; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "qc" THEN + NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {}; + p.opts.mask := {TextRulers.leftAdjust, TextRulers.rightAdjust}; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "qj" THEN + NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {TextRulers.leftAdjust, TextRulers.rightAdjust}; + p.opts.mask := {TextRulers.leftAdjust, TextRulers.rightAdjust}; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "sb" THEN + NEW(p); + p.valid := {TextRulers.lead}; p.lead := val * twips; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "sl" THEN + NEW(p); + p.valid := {TextRulers.grid}; p.grid := val * twips; + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "tqc" THEN + tabStyle := {TextRulers.centerTab} + ELSIF (comm = "tqr") OR (comm="tqdec") THEN + tabStyle := {TextRulers.rightTab} + ELSIF comm = "tb" THEN + p0 := pattr.Prop(); p := p0(TextRulers.Prop); + p.valid := {TextRulers.tabs}; + p.tabs.tab[p.tabs.len].stop := val * twips; + p.tabs.tab[p.tabs.len].type := {TextRulers.barTab}; tabStyle := {}; + INC(p.tabs.len); + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "tx" THEN + p0 := pattr.Prop(); p := p0(TextRulers.Prop); + p.valid := {TextRulers.tabs}; + p.tabs.tab[p.tabs.len].stop := val * twips; + p.tabs.tab[p.tabs.len].type := tabStyle; tabStyle := {}; + INC(p.tabs.len); + pattr := TextRulers.ModifiedAttr(pattr, p) + ELSIF comm = "pagebb" THEN + NEW(p); + p.valid := {TextRulers.opts}; p.opts.val := {TextRulers.pageBreak}; p.opts.mask := p.opts.val; + pattr := TextRulers.ModifiedAttr(pattr, p) + (* header *) + ELSIF comm = "deff" THEN + IF hasNum THEN defFont := val END + ELSIF comm = "fonttbl" THEN + IF dest # skip THEN dest := fonttab END + ELSIF comm = "colortbl" THEN + IF dest # skip THEN dest := colortab; cnum := 0; SetColor(0, 0) END + ELSIF comm = "red" THEN + IF dest = colortab THEN SetColor(cnum, Color(cnum).c + val MOD 256) END + ELSIF comm = "green" THEN + IF dest = colortab THEN SetColor(cnum, Color(cnum).c + val MOD 256 * 256) END + ELSIF comm = "blue" THEN + IF dest = colortab THEN SetColor(cnum, Color(cnum).c + val MOD 256 * 65536) END + ELSIF comm = "rtf" THEN + ELSIF comm = "ansi" THEN + ELSIF comm = "lang" THEN + ELSIF comm = "langfe" THEN + ELSIF comm = "loch" THEN + ELSIF comm = "ltrch" THEN + ELSIF comm = "rtlch" THEN + ELSIF comm = "ansicpg" THEN + (* misc *) + ELSIF comm = "bin" THEN rd.SetPos(rd.Pos() + val - 1); Next(ch) + (* unicode *) + ELSIF comm = "u" THEN Write(CHR(val)); skipCnt := uniCnt + ELSIF comm = "uc" THEN IF hasNum THEN uniCnt := val END + ELSIF comm = "upr" THEN dest := skip (* skip ANSI part *) + ELSIF comm = "ud" THEN dest := text (* use Unicode part *) + (* unhandled destinations *) + ELSIF comm = "author" THEN dest := skip + ELSIF comm = "buptim" THEN dest := skip + ELSIF comm = "comment" THEN dest := skip + ELSIF comm = "creatim" THEN dest := skip + ELSIF comm = "doccomm" THEN dest := skip + ELSIF comm = "footer" THEN dest := skip + ELSIF comm = "footerl" THEN dest := skip + ELSIF comm = "footerr" THEN dest := skip + ELSIF comm = "footerf" THEN dest := skip + ELSIF comm = "footnote" THEN dest := skip + ELSIF comm = "ftnsep" THEN dest := skip + ELSIF comm = "ftnsepc" THEN dest := skip + ELSIF comm = "ftncn" THEN dest := skip + ELSIF comm = "header" THEN dest := skip + ELSIF comm = "headerl" THEN dest := skip + ELSIF comm = "headerr" THEN dest := skip + ELSIF comm = "headerf" THEN dest := skip + ELSIF comm = "info" THEN dest := skip + ELSIF comm = "keywords" THEN dest := skip + ELSIF comm = "object" THEN dest := skip + ELSIF comm = "operator" THEN dest := skip + ELSIF comm = "pict" THEN dest := skip + ELSIF comm = "printim" THEN dest := skip + ELSIF comm = "private1" THEN dest := skip + ELSIF comm = "revtim" THEN dest := skip + ELSIF comm = "rxe" THEN dest := skip + ELSIF comm = "stylesheet" THEN dest := skip + ELSIF comm = "subject" THEN dest := skip + ELSIF comm = "tc" THEN dest := skip + ELSIF comm = "title" THEN dest := skip + ELSIF comm = "txe" THEN dest := skip + ELSIF comm = "xe" THEN dest := skip + ELSE (* unknown *) + IF skipDest & (con # NIL) & (con.next # NIL) THEN dest := skip END + END; + skipDest := FALSE + ELSIF ch = "'" THEN + Next(ch); + IF ch <= "9" THEN val := ORD(ch) - ORD("0") ELSE val := ORD(CAP(ch)) - ORD("A") + 10 END; + Next(ch); + IF ch <= "9" THEN val := 16 * val + ORD(ch) - ORD("0") + ELSE val := 16 * val + ORD(CAP(ch)) - ORD("A") + 10 + END; + Write(CHR(val)); Next(ch) + ELSE + IF ch = "~" THEN Write(0A0X) (* nonbreaking space *) + ELSIF ch = "-" THEN Write(0ADX) (* soft hyphen *) + ELSIF ch = "_" THEN Write(2011X) (* nonbreaking hyphen *) + ELSIF ch = "*" THEN skipDest := TRUE + ELSIF (ch = LF) OR (ch = CR) THEN Paragraph + ELSIF (ch = "{") OR (ch = "}") OR (ch = "\") THEN Write(ch) + END; + Next(ch) + END + ELSIF ch = ";" THEN + IF dest = fonttab THEN font := Font(fnum); font.f[idx] := 0X; INC(idx) + ELSIF dest = colortab THEN INC(cnum); SetColor(cnum, 0) + ELSIF dest = text THEN Write(";") + END; + Next(ch) + ELSIF ch >= " " THEN + Write(ch); Next(ch) + ELSE + Next(ch) + END + END + END ParseRichText; + + PROCEDURE ConvertToRichText (in: TextViews.View; beg, end: INTEGER; VAR out: TextModels.Model); + VAR r: TextModels.Reader; w: TextMappers.Formatter; ch: CHAR; f: Fonts.Font; + attr, attr0: TextModels.Attributes; col: Ports.Color; tf, atf: Fonts.Typeface; p, size, asize, offs: INTEGER; + style, astyle: SET; weight, aweight: INTEGER; rattr, rattr0: TextRulers.Attributes; ruler: TextRulers.Ruler; + text: TextModels.Model; firstLine, firstLine0: BOOLEAN; fonts: ARRAY 256 OF Fonts.Typeface; + colors: ARRAY 256 OF Ports.Color; fnum, cnum, i: INTEGER; + BEGIN + out := TextModels.dir.New(); w.ConnectTo(out); + f := Fonts.dir.Default(); tf := f.typeface; + fnum := 1; fonts[0] := tf; + cnum := 1; colors[0] := Ports.defaultColor; + col := Ports.defaultColor; size := 12 * Ports.point; + offs := 0; style := {}; weight := Fonts.normal; + attr0 := NIL; rattr0 := NIL; firstLine := TRUE; firstLine0 := FALSE; + text := in.ThisModel(); r := text.NewReader(NIL); + ruler := TextViews.ThisRuler(in, beg); rattr := ruler.style.attr; + r.SetPos(beg); r.ReadChar(ch); + WHILE ~r.eot & (r.Pos() <= end) DO + attr := r.attr; + IF (r.view # NIL) & (r.view IS TextRulers.Ruler) THEN + ruler := r.view(TextRulers.Ruler); rattr := ruler.style.attr; + firstLine := TRUE + ELSIF ch = FF THEN firstLine := TRUE + END; + IF (rattr # rattr0) OR (firstLine # firstLine0) THEN + IF (rattr # rattr0) OR (rattr.first # rattr.left) OR (rattr.lead # 0) OR (TextRulers.pageBreak IN rattr.opts) + THEN + w.WriteSString("\pard"); + IF rattr.left # 0 THEN + w.WriteSString("\li"); w.WriteInt(rattr.left DIV twips) + END; + IF firstLine & (rattr.first # rattr.left) THEN + w.WriteSString("\fi"); w.WriteInt((rattr.first - rattr.left) DIV twips) + END; + IF firstLine & (rattr.lead # 0) THEN + w.WriteSString("\sb"); w.WriteInt(rattr.lead DIV twips) + END; + IF rattr.grid > Ports.point THEN + w.WriteSString("\sl"); w.WriteInt(rattr.grid DIV twips); w.WriteSString("\slmult1") + END; + IF {TextRulers.leftAdjust, TextRulers.rightAdjust} - rattr.opts = {} THEN w.WriteSString("\qj") + ELSIF TextRulers.rightAdjust IN rattr.opts THEN w.WriteSString("\qr") + ELSIF ~(TextRulers.leftAdjust IN rattr.opts) THEN w.WriteSString("\qc") + END; + IF firstLine & (TextRulers.pageBreak IN rattr.opts) THEN + w.WriteSString("\pagebb") + END; + i := 0; + WHILE i < rattr.tabs.len DO + IF TextRulers.centerTab IN rattr.tabs.tab[i].type THEN w.WriteSString("\tqc") END; + IF TextRulers.rightTab IN rattr.tabs.tab[i].type THEN w.WriteSString("\tqr") END; + IF TextRulers.barTab IN rattr.tabs.tab[i].type THEN w.WriteSString("\tb") END; + w.WriteSString("\tx"); w.WriteInt(rattr.tabs.tab[i].stop DIV twips); + INC(i) + END; + w.WriteChar(" ") + END; + rattr0 := rattr; firstLine0 := firstLine + END; + IF attr # attr0 THEN + p := w.Pos(); + IF attr.color # col THEN + i := 0; WHILE (i < cnum) & (colors[i] # attr.color) DO INC(i) END; + IF i = cnum THEN colors[i] := attr.color; INC(cnum) END; + w.WriteSString("\cf"); w.WriteInt(i); + col := attr.color + END; + atf := attr.font.typeface$; asize := attr.font.size; astyle := attr.font.style; aweight := attr.font.weight; + IF atf # tf THEN + i := 0; WHILE (i < fnum) & (fonts[i] # atf) DO INC(i) END; + IF i = fnum THEN fonts[i] := atf; INC(fnum) END; + w.WriteSString("\f"); w.WriteInt(i); + tf := atf + END; + IF asize # size THEN + w.WriteSString("\fs"); w.WriteInt(asize DIV halfpoint); + size := asize + END; + IF astyle # style THEN + IF (Fonts.italic IN astyle) & ~(Fonts.italic IN style) THEN w.WriteSString("\i") + ELSIF ~(Fonts.italic IN astyle) & (Fonts.italic IN style) THEN w.WriteSString("\i0") + END; + IF (Fonts.underline IN astyle) & ~(Fonts.underline IN style) THEN w.WriteSString("\ul") + ELSIF ~(Fonts.underline IN astyle) & (Fonts.underline IN style) THEN w.WriteSString("\ul0") + END; + IF (Fonts.strikeout IN astyle) & ~(Fonts.strikeout IN style) THEN w.WriteSString("\strike") + ELSIF ~(Fonts.strikeout IN astyle) & (Fonts.strikeout IN style) THEN w.WriteSString("\strike0") + END; + style := astyle + END; + IF aweight # weight THEN + IF (aweight > Fonts.normal) & (weight = Fonts.normal) THEN w.WriteSString("\b") + ELSIF (aweight = Fonts.normal) & (weight > Fonts.normal) THEN w.WriteSString("\b0") + END; + weight := aweight + END; + IF attr.offset # offs THEN + IF attr.offset > 0 THEN w.WriteSString("\up"); w.WriteInt(attr.offset DIV halfpoint) + ELSIF attr.offset < 0 THEN w.WriteSString("\dn"); w.WriteInt(-(attr.offset DIV halfpoint)) + ELSIF offs > 0 THEN w.WriteSString("\up0") + ELSE w.WriteSString("\dn0") + END; + offs := attr.offset + END; + IF w.Pos() # p THEN w.WriteChar(" ") END; + attr0 := attr + END; + IF ch >= 100X THEN + IF ch = 2002X THEN w.WriteSString("\enspace ") + ELSIF ch = 2003X THEN w.WriteSString("\emspace ") + ELSIF ch = 2013X THEN w.WriteSString("\endash ") + ELSIF ch = 2014X THEN w.WriteSString("\emdash ") + ELSIF ch = 2010X THEN w.WriteChar("-") + ELSIF ch = 2011X THEN w.WriteSString("\_") + ELSIF ch = 201CX THEN (* unicode: left double quote *) w.WriteSString("\ldblquote ") + ELSIF ch = 201DX THEN (* unicode: right double quote *) w.WriteSString("\rdblquote ") + ELSIF ch = 2018X THEN (* unicode: left single quote *) w.WriteSString("\lquote ") + ELSIF ch = 2019X THEN (* unicode: right single quote *) w.WriteSString("\rquote ") + ELSE + w.WriteSString("\u"); w.WriteInt(ORD(ch)); + ch := ThisWndChar(ch); + IF ch >= 80X THEN + w.WriteSString("\'"); + w.WriteIntForm(ORD(ch), TextMappers.hexadecimal, 2, "0", FALSE) + ELSE + w.WriteChar(ch) + END + END + ELSE + CASE ch OF + | TAB: w.WriteSString("\tab ") + | CR: w.WriteSString("\par "); w.WriteLn; firstLine := FALSE + | " ".."[", "]".."z", "|", "~": w.WriteChar(ch) + | "\": w.WriteSString("\\") + | "{": w.WriteSString("\{") + | "}": w.WriteSString("\}") + | 8FX: (* digit space *) w.WriteChar(" ") + | 90X: (* hyphen *) w.WriteChar("-") + | 91X: (* non-breaking hyphen *) w.WriteSString("\_") + | 0A0X: (* non-breaking space *) w.WriteSString("\~") + | 0ADX: (* soft hyphen *) w.WriteSString("\-") + | 0A1X..0ACX, 0AEX..0FFX: + w.WriteSString("\'"); w.WriteIntForm(ORD(ch), TextMappers.hexadecimal, 2, "0", FALSE) + ELSE + END + END; + r.ReadChar(ch) + END; + w.WriteChar("}"); + (* header *) + w.SetPos(0); + w.WriteSString("{\rtf1\ansi\ansicpg1252\deff0"); + w.WriteSString("{\fonttbl"); i := 0; + WHILE i < fnum DO + IF fonts[i] = Fonts.default THEN fonts[i] := HostFonts.defFont.alias$ END; + w.WriteSString("{\f"); w.WriteInt(i); w.WriteSString("\fnil "); w.WriteString(fonts[i]); w.WriteSString(";}"); + INC(i) + END; + w.WriteChar("}"); w.WriteLn; + w.WriteSString("{\colortbl;"); i := 1; + WHILE i < cnum DO + w.WriteSString("\red"); w.WriteInt(colors[i] MOD 256); + w.WriteSString("\green"); w.WriteInt(colors[i] DIV 256 MOD 256); + w.WriteSString("\blue"); w.WriteInt(colors[i] DIV 65536 MOD 256); + w.WriteChar(";"); INC(i) + END; + w.WriteChar("}"); w.WriteLn; + w.WriteSString("\deftab216 "); + w.WriteSString("\plain") + END ConvertToRichText; + +(* + PROCEDURE ImportDText* (VAR med: WinOle.STGMEDIUM; OUT v: Views.View; + OUT w, h: INTEGER; OUT isSingle: BOOLEAN); + VAR t: TextModels.Model; res, adr: INTEGER; wr: TextModels.Writer; ch: SHORTCHAR; + hnd: WinApi.HANDLE; attr: TextModels.Attributes; p: Properties.StdProp; pref: Properties.BoundsPref; + BEGIN + hnd := MediumGlobal(med); + ASSERT(hnd # 0, 20); + adr := WinApi.GlobalLock(hnd); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + IF HostClipboard.cloneAttributes THEN + Properties.CollectStdProp(p); + NEW(attr); attr.InitFromProp(p); + wr.SetAttr(attr) + END; + SYSTEM.GET(adr, ch); + WHILE ch # 0X DO + WriteWndChar(wr, ch); + INC(adr); SYSTEM.GET(adr, ch) + END; + res := WinApi.GlobalUnlock(hnd); + v := TextViews.dir.New(t); + pref.w := Views.undefined; pref.h := Views.undefined; + Views.HandlePropMsg(v, pref); + w := pref.w; h := pref.h; isSingle := FALSE + END ImportDText; + + PROCEDURE ImportDRichText* (VAR med: WinOle.STGMEDIUM; OUT v: Views.View; + OUT w, h: INTEGER; OUT isSingle: BOOLEAN); + VAR t: TextModels.Model; res, adr: INTEGER; wr: TextModels.Writer; rd: MemReader; + hnd: WinApi.HANDLE; ruler: TextRulers.Ruler; pref: Properties.BoundsPref; + BEGIN + IF debug THEN + ImportDText(med, v, w, h, isSingle); + RETURN + END; + hnd := MediumGlobal(med); + ASSERT(hnd # 0, 20); + adr := WinApi.GlobalLock(hnd); + NEW(rd); rd.adr := adr; rd.pos := 0; + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + ParseRichText(rd, wr, ruler); + res := WinApi.GlobalUnlock(hnd); + v := TextViews.dir.New(t); + v(TextViews.View).SetDefaults(ruler, TextModels.dir.attr); + pref.w := Views.undefined; pref.h := Views.undefined; + Views.HandlePropMsg(v, pref); + w := pref.w; h := pref.h; isSingle := FALSE + END ImportDRichText; + + PROCEDURE ImportDUnicode* (VAR med: WinOle.STGMEDIUM; OUT v: Views.View; + OUT w, h: INTEGER; OUT isSingle: BOOLEAN); + VAR t: TextModels.Model; res, adr: INTEGER; wr: TextModels.Writer; uc: CHAR; + hnd: WinApi.HANDLE; attr: TextModels.Attributes; p: Properties.StdProp; pref: Properties.BoundsPref; + BEGIN + hnd := MediumGlobal(med); + ASSERT(hnd # 0, 20); + adr := WinApi.GlobalLock(hnd); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + IF HostClipboard.cloneAttributes THEN + Properties.CollectStdProp(p); + NEW(attr); attr.InitFromProp(p); + wr.SetAttr(attr) + END; + SYSTEM.GET(adr, uc); + WHILE uc # 0X DO + ASSERT(uc # 0FFFEX, 100); + IF uc < 100X THEN WriteWndChar(wr, uc) + ELSIF uc # 0FEFFX THEN wr.WriteChar(uc) + END; + INC(adr, 2); SYSTEM.GET(adr, uc) + END; + res := WinApi.GlobalUnlock(hnd); + v := TextViews.dir.New(t); + pref.w := Views.undefined; pref.h := Views.undefined; + Views.HandlePropMsg(v, pref); + w := pref.w; h := pref.h; isSingle := FALSE + END ImportDUnicode; + + PROCEDURE ExportDText* ( + v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM + ); + VAR t: TextModels.Model; r: TextModels.Reader; ch: CHAR; + res, len, adr: INTEGER; hnd: WinApi.HANDLE; + BEGIN + ASSERT(v # NIL, 20); + WITH v: TextViews.View DO + t := v.ThisModel(); + hnd := WinApi.GlobalAlloc({1, 13}, 2 * t.Length() + 1); (* movable, sharable *) + IF hnd # 0 THEN + adr := WinApi.GlobalLock(hnd); len := 0; + r := t.NewReader(NIL); r.ReadChar(ch); + WHILE ~r.eot DO + IF (ch # TextModels.viewcode) & (ch # TextModels.para) THEN + ch := ThisWndChar(ch); + SYSTEM.PUT(adr, SHORT(ch)); INC(adr); INC(len); + IF ch = CR THEN SYSTEM.PUT(adr, LF); INC(adr); INC(len) END + END; + r.ReadChar(ch) + END; + SYSTEM.PUT(adr, 0X); INC(len); + res := WinApi.GlobalUnlock(hnd); + hnd := WinApi.GlobalReAlloc(hnd, len, {}); + GenGlobalMedium(hnd, NIL, med) + END + ELSE + END + END ExportDText; + + PROCEDURE ExportDRichText* ( + v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM + ); + VAR t: TextModels.Model; r: TextModels.Reader; ch: CHAR; res, adr: INTEGER; hnd: WinApi.HANDLE; + BEGIN + ASSERT(v # NIL, 20); + WITH v: TextViews.View DO + ConvertToRichText(v, 0, MAX(INTEGER), t); + hnd := WinApi.GlobalAlloc({1, 13}, t.Length() + 1); (* movable, sharable *) + IF hnd # 0 THEN + adr := WinApi.GlobalLock(hnd); + r := t.NewReader(NIL); r.ReadChar(ch); + WHILE ~r.eot DO + SYSTEM.PUT(adr, SHORT(ch)); INC(adr); + r.ReadChar(ch) + END; + SYSTEM.PUT(adr, 0X); + res := WinApi.GlobalUnlock(hnd); + GenGlobalMedium(hnd, NIL, med) + END + ELSE + END + END ExportDRichText; + + PROCEDURE ExportDUnicode* ( + v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN; VAR med: WinOle.STGMEDIUM + ); + VAR t: TextModels.Model; r: TextModels.Reader; ch: CHAR; res, len, adr: INTEGER; hnd: WinApi.HANDLE; + BEGIN + ASSERT(v # NIL, 20); + WITH v: TextViews.View DO + t := v.ThisModel(); + hnd := WinApi.GlobalAlloc({1, 13}, 4 * t.Length() + 2); (* movable, sharable *) + IF hnd # 0 THEN + adr := WinApi.GlobalLock(hnd); len := 0; + r := t.NewReader(NIL); r.ReadChar(ch); + WHILE ~r.eot DO + IF ch = CR THEN + SYSTEM.PUT(adr, LONG(CR)); INC(adr, 2); INC(len, 2); + SYSTEM.PUT(adr, LONG(LF)); INC(adr, 2); INC(len, 2) + ELSIF (ch >= " ") OR (ch = TAB) THEN + IF (ch >= 0EF00X) & (ch <= 0EFFFX) THEN ch := CHR(ORD(ch) - 0EF00H) END; + SYSTEM.PUT(adr, ch); INC(adr, 2); INC(len, 2) + END; + r.ReadChar(ch) + END; + SYSTEM.PUT(adr, LONG(0X)); INC(len, 2); + res := WinApi.GlobalUnlock(hnd); + hnd := WinApi.GlobalReAlloc(hnd, len, {}); + GenGlobalMedium(hnd, NIL, med) + END + ELSE + END + END ExportDUnicode; +*) + + PROCEDURE ImportText* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; t: TextModels.Model; wr: TextModels.Writer; ch, nch: SHORTCHAR; + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); r.SetPos(0); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + r.ReadSChar(ch); + WHILE ~r.rider.eof DO + r.ReadSChar(nch); + IF (ch = CR) & (nch = LF) THEN r.ReadSChar(nch) + ELSIF ch = LF THEN ch := CR + END; + WriteWndChar(wr, ch); ch := nch + END; + s := TextViews.dir.New(t) + END ImportText; + + PROCEDURE ImportTabText* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; t: TextModels.Model; wr: TextModels.Writer; ch, nch: SHORTCHAR; + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); r.SetPos(0); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + r.ReadSChar(ch); + WHILE ~r.rider.eof DO + r.ReadSChar(nch); + IF (ch = CR) & (nch = LF) THEN r.ReadSChar(nch) + ELSIF ch = LF THEN ch := CR + ELSIF (ch = " ") & (nch = " ") THEN ch := TAB; r.ReadSChar(nch) + END; + WriteWndChar(wr, ch); ch := nch + END; + s := TextViews.dir.New(t) + END ImportTabText; + + PROCEDURE ImportRichText* (f: Files.File; OUT s: Stores.Store); + VAR t: TextModels.Model; wr: TextModels.Writer; rd: Files.Reader; ruler: TextRulers.Ruler; + BEGIN + rd := f.NewReader(NIL); rd.SetPos(0); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + ParseRichText(rd, wr, ruler); + s := TextViews.dir.New(t); + s(TextViews.View).SetDefaults(ruler, TextModels.dir.attr) + END ImportRichText; + + PROCEDURE ImportUnicode* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; t: TextModels.Model; v: TextViews.View; w: TextModels.Writer; + ch0, ch1: SHORTCHAR; len, res: INTEGER; uc: CHAR; rev: BOOLEAN; + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); r.SetPos(0); + len := f.Length(); rev := FALSE; + t := TextModels.dir.New(); w := t.NewWriter(NIL); w.SetPos(0); + WHILE len > 0 DO + r.ReadSChar(ch0); r.ReadSChar(ch1); + IF rev THEN uc := CHR(ORD(ch1) + 256 * ORD(ch0)) + ELSE uc := CHR(ORD(ch0) + 256 * ORD(ch1)) + END; + DEC(len, 2); + IF uc = 0FFFEX THEN rev := ~rev + ELSIF uc < 100X THEN WriteWndChar(w, uc) + ELSIF uc # 0FEFFX THEN w.WriteChar(uc) + END + END; + v := TextViews.dir.New(t); + s := v + END ImportUnicode; + + PROCEDURE ImportDosText* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; t: TextModels.Model; wr: TextModels.Writer; ch, nch: SHORTCHAR; + + PROCEDURE ConvertChar (wr: TextModels.Writer; ch: CHAR); + (* PC Code Page Mappings M4 (Latin) to Unicode Encoding *) + (* Reference: The Unicode Standard, Version 1.0, Vol 1, Addison Wesley, p. 536 *) + BEGIN + CASE ch OF + | CR, TAB, " "..7EX: wr.WriteChar(ch) + | LF: + | 080X: wr.WriteChar(0C7X) + | 081X: wr.WriteChar(0FCX) + | 082X: wr.WriteChar(0E9X) + | 083X: wr.WriteChar(0E2X) + | 084X: wr.WriteChar(0E4X) + | 085X: wr.WriteChar(0E0X) + | 086X: wr.WriteChar(0E5X) + | 087X: wr.WriteChar(0E7X) + | 088X: wr.WriteChar(0EAX) + | 089X: wr.WriteChar(0EBX) + | 08AX: wr.WriteChar(0E8X) + | 08BX: wr.WriteChar(0EFX) + | 08CX: wr.WriteChar(0EEX) + | 08DX: wr.WriteChar(0ECX) + | 08EX: wr.WriteChar(0C4X) + | 08FX: wr.WriteChar(0C5X) + | 090X: wr.WriteChar(0C9X) + | 091X: wr.WriteChar(0E6X) + | 092X: wr.WriteChar(0C6X) + | 093X: wr.WriteChar(0F4X) + | 094X: wr.WriteChar(0F6X) + | 095X: wr.WriteChar(0F2X) + | 096X: wr.WriteChar(0FBX) + | 097X: wr.WriteChar(0F9X) + | 098X: wr.WriteChar(0FFX) + | 099X: wr.WriteChar(0D6X) + | 09AX: wr.WriteChar(0DCX) + | 09BX: wr.WriteChar(0F8X) + | 09CX: wr.WriteChar(0A3X) + | 09DX: wr.WriteChar(0D8X) + | 09EX: wr.WriteChar(0D7X) + | 09FX: wr.WriteChar(0192X) + | 0A0X: wr.WriteChar(0E1X) + | 0A1X: wr.WriteChar(0EDX) + | 0A2X: wr.WriteChar(0F3X) + | 0A3X: wr.WriteChar(0FAX) + | 0A4X: wr.WriteChar(0F1X) + | 0A5X: wr.WriteChar(0D1X) + | 0A6X: wr.WriteChar(0AAX) + | 0A7X: wr.WriteChar(0BAX) + | 0A8X: wr.WriteChar(0BFX) + | 0A9X: wr.WriteChar(0AEX) + | 0AAX: wr.WriteChar(0ACX) + | 0ABX: wr.WriteChar(0BDX) + | 0ACX: wr.WriteChar(0BCX) + | 0ADX: wr.WriteChar(0A1X) + | 0AEX: wr.WriteChar(0ABX) + | 0AFX: wr.WriteChar(0BBX) + | 0B5X: wr.WriteChar(0C1X) + | 0B6X: wr.WriteChar(0C2X) + | 0B7X: wr.WriteChar(0C0X) + | 0B8X: wr.WriteChar(0A9X) + | 0BDX: wr.WriteChar(0A2X) + | 0BEX: wr.WriteChar(0A5X) + | 0C6X: wr.WriteChar(0E3X) + | 0C7X: wr.WriteChar(0C3X) + | 0CFX: wr.WriteChar(0A4X) + | 0D0X: wr.WriteChar(0F0X) + | 0D1X: wr.WriteChar(0D0X) + | 0D2X: wr.WriteChar(0CAX) + | 0D3X: wr.WriteChar(0CBX) + | 0D4X: wr.WriteChar(0C8X) + | 0D5X: wr.WriteChar(0131X) + | 0D6X: wr.WriteChar(0CDX) + | 0D7X: wr.WriteChar(0CEX) + | 0D8X: wr.WriteChar(0CFX) + | 0DDX: wr.WriteChar(0A6X) + | 0DEX: wr.WriteChar(0CCX) + | 0E0X: wr.WriteChar(0D3X) + | 0E1X: wr.WriteChar(0DFX) + | 0E2X: wr.WriteChar(0D4X) + | 0E3X: wr.WriteChar(0D2X) + | 0E4X: wr.WriteChar(0F5X) + | 0E5X: wr.WriteChar(0D5X) + | 0E6X: wr.WriteChar(0B5X) + | 0E7X: wr.WriteChar(0FEX) + | 0E8X: wr.WriteChar(0DEX) + | 0E9X: wr.WriteChar(0DAX) + | 0EAX: wr.WriteChar(0DBX) + | 0EBX: wr.WriteChar(0D9X) + | 0ECX: wr.WriteChar(0FDX) + | 0EDX: wr.WriteChar(0DDX) + | 0EEX: wr.WriteChar(0AFX) + | 0EFX: wr.WriteChar(0B4X) + | 0F0X: wr.WriteChar(0ADX) + | 0F1X: wr.WriteChar(0B1X) + | 0F2X: wr.WriteChar(02017X) + | 0F3X: wr.WriteChar(0BEX) + | 0F4X: wr.WriteChar(0B6X) + | 0F5X: wr.WriteChar(0A7X) + | 0F6X: wr.WriteChar(0F7X) + | 0F7X: wr.WriteChar(0B8X) + | 0F8X: wr.WriteChar(0B0X) + | 0F9X: wr.WriteChar(0A8X) + | 0FAX: wr.WriteChar(0B7X) + | 0FBX: wr.WriteChar(0B9X) + | 0FCX: wr.WriteChar(0B3X) + | 0FDX: wr.WriteChar(0B2X) + | 0X..8X, 0BX, 0CX, 0EX..1FX, 7FX, + 0B0X..0B4X, 0B9X..0BCX, 0BFX..0C5X, 0C8X..0CEX, 0D9X..0DCX, 0DFX, 0FEX, 0FFX: + wr.WriteChar(CHR(0EF00H + ORD(ch))) + END + END ConvertChar; + + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); r.SetPos(0); + t := TextModels.dir.New(); wr := t.NewWriter(NIL); + r.ReadSChar(ch); + WHILE ~r.rider.eof DO + r.ReadSChar(nch); + IF (ch = CR) & (nch = LF) THEN r.ReadSChar(nch) + ELSIF ch = LF THEN ch := CR + END; + ConvertChar(wr, ch); ch := nch + END; + s := TextViews.dir.New(t) + END ImportDosText; + + PROCEDURE TextView(s: Stores.Store): Stores.Store; + BEGIN + IF s IS Views.View THEN RETURN Properties.ThisType(s(Views.View), "TextViews.View") + ELSE RETURN NIL + END + END TextView; + + PROCEDURE ExportText* (s: Stores.Store; f: Files.File); + VAR w: Stores.Writer; t: TextModels.Model; r: TextModels.Reader; ch: CHAR; + BEGIN + ASSERT(s # NIL, 20); ASSERT(f # NIL, 21); + s := TextView(s); + IF s # NIL THEN + w.ConnectTo(f); w.SetPos(0); + t := s(TextViews.View).ThisModel(); + IF t # NIL THEN + r := t.NewReader(NIL); + r.ReadChar(ch); + WHILE ~r.eot DO + IF (ch # TextModels.viewcode) & (ch # TextModels.para) THEN + ch := ThisWndChar(ch); + w.WriteSChar(SHORT(ch)); + IF ch = CR THEN w.WriteSChar(LF) END + END; + r.ReadChar(ch) + END + END + END + END ExportText; + + PROCEDURE ExportTabText* (s: Stores.Store; f: Files.File); + VAR w: Stores.Writer; t: TextModels.Model; r: TextModels.Reader; ch: CHAR; + BEGIN + ASSERT(s # NIL, 20); ASSERT(f # NIL, 21); + s := TextView(s); + IF s # NIL THEN + w.ConnectTo(f); w.SetPos(0); + t := s(TextViews.View).ThisModel(); + IF t # NIL THEN + r := t.NewReader(NIL); + r.ReadChar(ch); + WHILE ~r.eot DO + IF (ch # TextModels.viewcode) & (ch # TextModels.para) THEN + ch := ThisWndChar(ch); + IF ch = CR THEN w.WriteSChar(CR); w.WriteSChar(LF) + ELSIF ch = TAB THEN w.WriteSChar(" "); w.WriteSChar(" ") + ELSE w.WriteSChar(SHORT(ch)) + END + END; + r.ReadChar(ch) + END + END + END + END ExportTabText; + + PROCEDURE ExportRichText* (s: Stores.Store; f: Files.File); + VAR t: TextModels.Model; r: TextModels.Reader; ch: CHAR; w: Stores.Writer; + BEGIN + ASSERT(s # NIL, 20); ASSERT(f # NIL, 21); + WITH s: TextViews.View DO + ConvertToRichText(s, 0, MAX(INTEGER), t); + w.ConnectTo(f); w.SetPos(0); + r := t.NewReader(NIL); r.ReadChar(ch); + WHILE ~r.eot DO + w.WriteSChar(SHORT(ch)); r.ReadChar(ch) + END +(* + w.WriteSChar(0X) +*) + ELSE + END + END ExportRichText; + + PROCEDURE ExportUnicode* (s: Stores.Store; f: Files.File); + VAR w: Stores.Writer; t: TextModels.Model; r: TextModels.Reader; ch: CHAR; + BEGIN + ASSERT(s # NIL, 20); ASSERT(f # NIL, 21); + s := TextView(s); + IF s # NIL THEN + w.ConnectTo(f); w.SetPos(0); + w.WriteChar(0FEFFX); (* little endian *) + t := s(TextViews.View).ThisModel(); + IF t # NIL THEN + r := t.NewReader(NIL); + r.ReadChar(ch); + WHILE ~r.eot DO + IF ch = CR THEN + w.WriteChar(CR); w.WriteChar(LF) + ELSIF (ch >= " ") OR (ch = TAB) THEN + IF (ch >= 0EF00X) & (ch <= 0EFFFX) THEN ch := CHR(ORD(ch) - 0EF00H) END; + w.WriteChar(ch) + END; + r.ReadChar(ch) + END + END + END + END ExportUnicode; + + PROCEDURE ImportHex* (f: Files.File; OUT s: Stores.Store); + VAR r: Stores.Reader; t: TextModels.Model; w: TextMappers.Formatter; ch: SHORTCHAR; a: INTEGER; + i: INTEGER; str: ARRAY 17 OF CHAR; + BEGIN + ASSERT(f # NIL, 20); + r.ConnectTo(f); r.SetPos(0); + t := TextModels.dir.New(); + w.ConnectTo(t); w.SetPos(0); + r.ReadSChar(ch); a := 0; + WHILE ~r.rider.eof DO + IF a MOD 16 = 0 THEN + w.WriteChar("["); + w.WriteIntForm(a, TextMappers.hexadecimal, 8, "0", FALSE); + w.WriteSString("]") + END; + w.WriteIntForm(ORD(ch), TextMappers.hexadecimal, 2, "0", FALSE); + IF ch > 20X THEN str[a MOD 16] := ch ELSE str[a MOD 16] := "" END; + INC(a); + IF a MOD 16 = 0 THEN + str[16] := 0X; w.WriteString(""); w.WriteString(str); + w.WriteLn + ELSIF a MOD 4 = 0 THEN + w.WriteString("") + ELSE + w.WriteChar("") + END; + r.ReadSChar(ch) + END; + IF a MOD 16 # 0 THEN + str[a MOD 16] := 0X; + i := (16 - a MOD 16) * 3 + (3 - a MOD 16 DIV 4) + 3; + WHILE i # 0 DO w.WriteChar(""); DEC(i) END; + w.WriteString(str) + END; + s := TextViews.dir.New(t) + END ImportHex; + +END HostTextConv. diff --git a/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox-dl.c b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox-dl.c new file mode 100644 index 0000000..c4ac847 --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox-dl.c @@ -0,0 +1,48 @@ +#include +#include + +int main (int argc, char *argv[]) +{ + void * h; + /* + void * h1; + void (*SetKernelBaseStack) (int); + void (*Init) (void); + */ + int res; + + h = dlopen("libBB.so", RTLD_LAZY | RTLD_GLOBAL); + if (h != NULL) { + /* + h1 = dlsym(h, "SetKernelBaseStack"); + if (h1 != NULL) { + *(void **) (&SetKernelBaseStack) = h1; + h1 = dlsym(h, "Init"); + if (h1 != NULL) { + *(void **) (&Init) = h1; + + asm ("movl %%esp, %[res]" : [res] "=m" (res) ); + SetKernelBaseStack(res - 8); + + printf("before Init()\n"); + Init(); + printf("after Init()\n"); + + res = 0; + } else { + perror(dlerror()); + res = 3; + } + } else { + perror(dlerror()); + res = 2; + } + */ + res = 0; + } else { + perror(dlerror()); + res = 1; + } + + return res; +} diff --git a/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox.c b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox.c new file mode 100644 index 0000000..1e77b70 --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox.c @@ -0,0 +1,4 @@ +int main (int argc, char *argv[]) +{ + return 0; +} diff --git a/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox1.c b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox1.c new file mode 100644 index 0000000..155069f --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox1.c @@ -0,0 +1,24 @@ +// #include + +// extern void SetKernelBaseStack (int); +extern void Init (void); + +int main (int argc, char *argv[]) +{ + // int res; + + // printf("START\n"); + + /* 2012.09.02: This is from oberoncore.ru + 2012.09.05: not required in case of static linking of shared library (-lBB) */ + // asm ("movl %%esp, %[res]" : [res] "=m" (res) ); + // SetKernelBaseStack(res - 8); + // printf("SetKernelBaseStack(0x%02x): done\n", res - 8); + // -> base stack = locals of main proc + + Init(); + + // printf("END\n"); + + return 0; +} diff --git a/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/dev0.c b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/dev0.c new file mode 100644 index 0000000..64bddd7 --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/dev0.c @@ -0,0 +1,18 @@ +#include +#include + +int main (int argc, char *argv[]) +{ + void * h; + int res; + + h = dlopen("libBB0.so", RTLD_LAZY | RTLD_GLOBAL); + if (h != NULL) { + res = 0; + } else { + perror(dlerror()); + res = 1; + } + + return res; +} diff --git a/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.odc b/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.odc new file mode 100644 index 0000000..a4476b4 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.txt b/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.txt new file mode 100644 index 0000000..bc2049e --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/System/Mod/Config.txt @@ -0,0 +1,27 @@ +MODULE Config; + + (* THIS IS TEXT COPY OF Config.odc *) + (* DO NOT EDIT *) + + IMPORT Dialog, Converters; + + PROCEDURE Setup*; + VAR res: INTEGER; + BEGIN + Converters.Register("HostTextConv.ImportText", "HostTextConv.ExportText", "TextViews.View", "txt", {Converters.importAll}); + Converters.Register("HostTextConv.ImportRichText", "HostTextConv.ExportRichText", "TextViews.View", "rtf", {}); + Converters.Register("HostTextConv.ImportUnicode", "HostTextConv.ExportUnicode", "TextViews.View", "utf", {}); + Converters.Register("HostTextConv.ImportDosText", "", "TextViews.View", "txt", {}); + Converters.Register("HostTextConv.ImportHex", "", "TextViews.View", "dat", {Converters.importAll}); + Converters.Register("HostTextConv.ImportText", "HostTextConv.ExportText", "TextViews.View", "xml", {}); + Converters.Register("HostTextConv.ImportText", "HostTextConv.ExportText", "TextViews.View", "html", {}); + Converters.Register("DevBrowser.ImportSymFile", "", "TextViews.View", "osf", {}); + Converters.Register("DevBrowser.ImportCodeFile", "", "TextViews.View", "ocf", {}); + Converters.Register("HostBitmaps.ImportBitmap", "HostBitmaps.ExportBitmap", "HostBitmaps.StdView", "bmp", {}); + Converters.Register("StdETHConv.ImportETHDoc", "", "TextViews.View", "eth", {Converters.importAll}); + Converters.Register("", "XhtmlExporter.ExportText", "TextViews.View", "html", {}); + + Dialog.Call("StdLog.Open", "", res) + END Setup; + +END Config. diff --git a/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.odc b/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.odc new file mode 100644 index 0000000..de16640 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt b/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt new file mode 100644 index 0000000..bb5bba2 --- /dev/null +++ b/Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt @@ -0,0 +1,27 @@ +MODULE Kernel_so_init; + + (* THIS IS TEXT COPY OF Kernel_so_init.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, SYSTEM; + + PROCEDURE SetKernelBaseStack* (x: INTEGER); + VAR + m: Kernel.Module; + ref, adr: INTEGER; mode, form: SHORTCHAR; desc: Kernel.Type; name: Kernel.Name; + BEGIN + m := Kernel.modList; + WHILE (m # NIL) & ~(m.name = "Kernel") DO + m := m.next + END; + ASSERT(m # NIL, 100); + ref := m.refs; Kernel.GetRefProc(ref, adr, name); ASSERT(adr # 0, 101); + Kernel.GetRefVar(ref, mode, form, desc, adr, name); + WHILE (mode = 1X) & ~(name = "baseStack") DO + Kernel.GetRefVar(ref, mode, form, desc, adr, name) + END; + ASSERT(mode = 1X, 102); ASSERT(form = 6X, 103); + SYSTEM.PUT(m.data + adr, x) + END SetKernelBaseStack; + +END Kernel_so_init. diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Build-Tool.odc b/Trurl-based/_LinuxOpenBSD_GUI/Build-Tool.odc new file mode 100644 index 0000000..098e314 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Build-Tool.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Docu/ObjectHierarchy.odc b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Docu/ObjectHierarchy.odc new file mode 100644 index 0000000..a0c4755 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Docu/ObjectHierarchy.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Keysyms.odc b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Keysyms.odc new file mode 100644 index 0000000..d56f40c Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Keysyms.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Util.odc b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Util.odc new file mode 100644 index 0000000..f18087c Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Util.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/CFrames.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/CFrames.odc new file mode 100644 index 0000000..b1dad61 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/CFrames.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Clipboard.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Clipboard.odc new file mode 100644 index 0000000..81e6d78 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Clipboard.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Cmds.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Cmds.odc new file mode 100644 index 0000000..059b601 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Cmds.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Dialog.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Dialog.odc new file mode 100644 index 0000000..aae8770 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Dialog.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Fonts.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Fonts.odc new file mode 100644 index 0000000..47930e4 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Fonts.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Mechanisms.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Mechanisms.odc new file mode 100644 index 0000000..0bd4a97 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Mechanisms.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Menus.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Menus.odc new file mode 100644 index 0000000..2bc74f3 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Menus.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/PackedFiles.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/PackedFiles.odc new file mode 100644 index 0000000..bb3a98d Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/PackedFiles.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Ports.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Ports.odc new file mode 100644 index 0000000..51915c0 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Ports.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Registry.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Registry.odc new file mode 100644 index 0000000..f1fd7ff Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Registry.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/TabFrames.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/TabFrames.odc new file mode 100644 index 0000000..31b333f Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/TabFrames.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Utf8.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Utf8.odc new file mode 100644 index 0000000..56c5d1e Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Utf8.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Windows.odc b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Windows.odc new file mode 100644 index 0000000..73cb683 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Windows.odc differ diff --git a/Trurl-based/_LinuxOpenBSD_GUI/TODO.odc b/Trurl-based/_LinuxOpenBSD_GUI/TODO.odc new file mode 100644 index 0000000..74a7a08 Binary files /dev/null and b/Trurl-based/_LinuxOpenBSD_GUI/TODO.odc differ diff --git a/Trurl-based/_Linux_/BlackBox b/Trurl-based/_Linux_/BlackBox new file mode 120000 index 0000000..b4db3bb --- /dev/null +++ b/Trurl-based/_Linux_/BlackBox @@ -0,0 +1 @@ +Lin/Rsrc/loader/BlackBox \ No newline at end of file diff --git a/Trurl-based/_Linux_/Host/Mod/Console.odc b/Trurl-based/_Linux_/Host/Mod/Console.odc new file mode 100644 index 0000000..8b94bed Binary files /dev/null and b/Trurl-based/_Linux_/Host/Mod/Console.odc differ diff --git a/Trurl-based/_Linux_/Host/Mod/Console.txt b/Trurl-based/_Linux_/Host/Mod/Console.txt new file mode 100644 index 0000000..da1e9a5 --- /dev/null +++ b/Trurl-based/_Linux_/Host/Mod/Console.txt @@ -0,0 +1,156 @@ +MODULE HostConsole; + + (* THIS IS TEXT COPY OF Console.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Console, Libc := LinLibc, Iconv := LinIconv, HostLang, Kernel; + + CONST + defCh = '?'; + + TYPE + Cons = POINTER TO RECORD (Console.Console) END; + + VAR + cons: Cons; + e, d: Iconv.iconv_t; + + PROCEDURE ResetCodec (c: Iconv.iconv_t): BOOLEAN; + VAR res, fLen, tLen: Iconv.size_t; + BEGIN + fLen := 0; tLen := 0; + res := Iconv.iconv(c, NIL, fLen, NIL, tLen); + RETURN res # -1 + END ResetCodec; + + PROCEDURE (cons: Cons) ReadLn (OUT s: ARRAY OF CHAR); + CONST + maxLineLen = 1023; (* without null terminating shortchar *) + VAR + i: INTEGER; + str: Libc.PtrSTR; + ss: ARRAY maxLineLen+1 OF SHORTCHAR; + fR, fLen, tW, tLen: INTEGER; + st: BOOLEAN; + res: Iconv.size_t; + from: Iconv.PtrSTR; to: Iconv.PtrLSTR; + BEGIN + ss[LEN(ss)-1] := 0X; + str := Libc.fgets(ss, LEN(ss), Libc.stdin); + IF (str # NIL) & (ss[LEN(ss)-1] = 0X) THEN + fLen := LEN(ss$); + IF fLen < LEN(s) THEN + IF d # -1 THEN + IF ResetCodec(d) THEN + from := ss; to := s; tLen := (LEN(s) - 1) * SIZE(CHAR) (* 2 *); + res := Iconv.iconv_decode(d, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X + ELSE s[0] := 0X + END + ELSE s[0] := 0X + END + ELSE + i := 0; + WHILE (ss[i] > 0X) & (ss[i] < 80X) DO s[i] := ss[i]; INC(i) END; + IF ss[i] = 0X THEN s[i] := 0X + ELSE s[0] := 0X + END + END + ELSE s[0] := 0X + END + ELSE s[0] := 0X + END + END ReadLn; + + PROCEDURE Printf (IN s: ARRAY OF CHAR; len: INTEGER); + CONST + maxShortCharsPerChar = 4; + ssLen = 128; (* >= maxShortCharsPerChar + 1 *) + VAR + ss: ARRAY ssLen OF SHORTCHAR; + fR, fLen, tW, tLen, n: INTEGER; + res: INTEGER; + res1: Iconv.size_t; + from: Iconv.PtrLSTR; to: Iconv.PtrSTR; + BEGIN + fR := 0; from := s; + WHILE len > 0 DO + tW := 0; to := ss; + IF e # -1 THEN + tLen := LEN(ss) - 1; + n := MIN(len, tLen DIV maxShortCharsPerChar); + fLen := n * SIZE(CHAR) (* 2 *); + REPEAT + res1 := Iconv.iconv_encode(e, from, fLen, to, tLen); + IF ~((res1 >= 0) & (fLen = 0) & (tLen >= 0)) THEN + ASSERT(tLen >= 0, 100); + ASSERT(fLen >= SIZE(CHAR), 101); + ASSERT(ResetCodec(e), 102); + to[0] := defCh; to := SYSTEM.VAL(Iconv.PtrSTR, SYSTEM.VAL(INTEGER, to) + 1); + DEC(tLen); + from := SYSTEM.VAL(Iconv.PtrLSTR, SYSTEM.VAL(INTEGER, from) + SIZE(CHAR)); + DEC(fLen, SIZE(CHAR)) + END + UNTIL fLen = 0; + to[0] := 0X + ELSE + fLen := MIN(len, LEN(ss) - 1); n := fLen; + WHILE fLen > 0 DO + IF s[fR] < 80X THEN ss[tW] := SHORT(s[fR]) + ELSE ss[tW] := defCh + END; + INC(tW); + INC(fR); DEC(fLen) + END; + ss[tW] := 0X + END; + res := Libc.printf(ss); + res := Libc.fflush(Libc.NULL); + + len := len - n + END + END Printf; + + PROCEDURE (cons: Cons) WriteChar (c: CHAR); + VAR s: ARRAY 1 OF CHAR; + BEGIN + s[0] := c; + Printf(s, 1) + END WriteChar; + + PROCEDURE (cons: Cons) WriteStr (IN text: ARRAY OF CHAR); + BEGIN + Printf(text, LEN(text$)) + END WriteStr; + + PROCEDURE (cons: Cons) WriteLn; + BEGIN + Printf(0AX, 1) + END WriteLn; + + PROCEDURE Init; + BEGIN + IF Kernel.littleEndian THEN + e := Iconv.iconv_open(HostLang.enc, "UCS-2LE"); + d := Iconv.iconv_open("UCS-2LE", HostLang.enc) + ELSE + e := Iconv.iconv_open(HostLang.enc, "UCS-2BE"); + d := Iconv.iconv_open("UCS-2BE", HostLang.enc) + END; + + NEW(cons); + Console.SetConsole(cons) + END Init; + + PROCEDURE Close; + VAR res: INTEGER; + BEGIN + IF e # -1 THEN res := Iconv.iconv_close(e); e := -1 END; + IF d # -1 THEN res := Iconv.iconv_close(d); d := -1 END + END Close; + +BEGIN + Init +CLOSE + Close +END HostConsole. diff --git a/Trurl-based/_Linux_/Host/Mod/Dates.odc b/Trurl-based/_Linux_/Host/Mod/Dates.odc new file mode 100644 index 0000000..0e179ef Binary files /dev/null and b/Trurl-based/_Linux_/Host/Mod/Dates.odc differ diff --git a/Trurl-based/_Linux_/Host/Mod/Dates.txt b/Trurl-based/_Linux_/Host/Mod/Dates.txt new file mode 100644 index 0000000..16e8621 --- /dev/null +++ b/Trurl-based/_Linux_/Host/Mod/Dates.txt @@ -0,0 +1,92 @@ +MODULE HostDates; + + (* THIS IS TEXT COPY OF Dates.odc *) + (* DO NOT EDIT *) + + IMPORT + SYSTEM, LinLibc, Dates; + + (* Dates Hook *) + + TYPE + DatesHook = POINTER TO RECORD (Dates.Hook) END; + + (* + + Some conversions are needed between the Linux and the BlackBox representations of dates. The following + table shows the differences: + +(!) Linux BlackBox + year from year 1900 from year 0000 + month range 0-11 range 1-12 + weekday 0:sunday - 6:satruday 0:monday - 6:sunday + (!) *) + + PROCEDURE (h: DatesHook) DateToString (d: Dates.Date; format: INTEGER; OUT str: ARRAY OF CHAR); + VAR tm: LinLibc.tmDesc; sstr: ARRAY 64 OF SHORTCHAR; res: LinLibc.size_t; + BEGIN + ASSERT(format IN {Dates.short, Dates.abbreviated, Dates.long, Dates.plainAbbreviated, Dates.plainLong}, 20); + tm.tm_year := d.year - 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + tm.tm_mon := d.month - 1; tm.tm_mday := d.day; + tm.tm_wday := (Dates.DayOfWeek(d) + 1) MOD 7; + IF format = Dates.short THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%x", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.abbreviated THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%a, %b %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.long THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%A, %B %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.plainAbbreviated THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%b %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSE (* format = Dates.plainLong *) + res := LinLibc.strftime(sstr, LEN(sstr), "%B %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + END; + IF res > 0 THEN str := sstr$ELSE str := "invalid date" END + END DateToString; + + PROCEDURE (h: DatesHook) GetTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.localtime(time); + d.year := tm.tm_year + 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + d.month := tm.tm_mon + 1; d.day := tm.tm_mday; + t.hour := tm.tm_hour; t.minute := tm.tm_min; t.second := tm.tm_sec + END GetTime; + + PROCEDURE (h: DatesHook) GetUTCBias (OUT bias: INTEGER); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.localtime(time); (* call to localtime needed to make sure that timezone is set *) + bias := LinLibc.timezone DIV 60; + END GetUTCBias; + + PROCEDURE (h: DatesHook) GetUTCTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.gmtime(time); + d.year := tm.tm_year + 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + d.month := tm.tm_mon + 1; d.day := tm.tm_mday; + t.hour := tm.tm_hour; t.minute := tm.tm_min; t.second := tm.tm_sec + END GetUTCTime; + + PROCEDURE (h: DatesHook) TimeToString (t: Dates.Time; OUT str: ARRAY OF CHAR); + VAR tm: LinLibc.tmDesc; sstr: ARRAY 64 OF SHORTCHAR; res: LinLibc.size_t; + BEGIN + tm.tm_hour := t.hour; tm.tm_min := t.minute; tm.tm_sec := t.second; + res := LinLibc.strftime(sstr, LEN(sstr), "%X", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))); + IF res > 0 THEN str := sstr$ELSE str := "invalid time" END + END TimeToString; + + + PROCEDURE Init; + VAR + datesHook: DatesHook; + BEGIN + NEW(datesHook); Dates.SetHook(datesHook); + END Init; + +BEGIN + Init +END HostDates. diff --git a/Trurl-based/_Linux_/Host/Mod/Files.odc b/Trurl-based/_Linux_/Host/Mod/Files.odc new file mode 100644 index 0000000..e20e891 Binary files /dev/null and b/Trurl-based/_Linux_/Host/Mod/Files.odc differ diff --git a/Trurl-based/_Linux_/Host/Mod/Files.txt b/Trurl-based/_Linux_/Host/Mod/Files.txt new file mode 100644 index 0000000..3aa3382 --- /dev/null +++ b/Trurl-based/_Linux_/Host/Mod/Files.txt @@ -0,0 +1,1501 @@ +MODULE HostFiles; + + (* THIS IS TEXT COPY OF Files.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.11: filenames encoding translation implemented + *) + + IMPORT SYSTEM, Kernel, Files, LinLibc, Iconv := LinIconv; + + CONST + tempName = "odcxxxxx"; + docType = "odc"; + + serverVersion = TRUE; + + pathLen* = 260; + + nofbufs = 4; (* max number of buffers per file *) + bufsize = 2 * 1024; (* size of each buffer *) + + invalid = LinLibc.NULL; + + temp = 0; new = 1; shared = 2; hidden = 3; exclusive = 4; closed = 5; (* file states *) + create = -1; + + ok = 0; + invalidName = 1; + invalidNameErr = MAX(INTEGER); (* On Windows this is 123 *) + notFound = 2; + fileNotFoundErr = LinLibc.ENOENT; + pathNotFoundErr = LinLibc.ENOENT; + existsAlready = 3; + fileExistsErr = LinLibc.EEXIST; + alreadyExistsErr = LinLibc.EEXIST; (* is alreadyExistsErr needed? *) + writeProtected = 4; + writeProtectedErr = LinLibc.EACCES; + ioError = 5; (* same as LinLibc.EIO *) + accessDenied = 6; + accessDeniedErr = LinLibc.EACCES; + sharingErr = LinLibc.EACCES; + netAccessDeniedErr = LinLibc.EACCES; + notEnoughMem = 80; + notEnoughMemoryErr = LinLibc.ENOMEM; + notEnoughDisk = 81; + diskFullErr = LinLibc.EDQUOT; + tooManyOpenFilesErr = LinLibc.EMFILE; + + noMoreFilesErr = 18; + + cancel = -8; retry = -9; + + TYPE + FullName* = ARRAY pathLen OF CHAR; + + Locator* = POINTER TO RECORD (Files.Locator) + path-: FullName; (* without trailing "/" *) + maxLen-: INTEGER; (* maximum name length *) + caseSens-: BOOLEAN; (* case sensitive file compares *) + rootLen-: INTEGER (* for network version *) + END; + + Buffer = POINTER TO RECORD + dirty: BOOLEAN; + org, len: INTEGER; + data: ARRAY bufsize OF BYTE + END; + + File = POINTER TO RECORD (Files.File) + state: INTEGER; + name: FullName; + ref: LinLibc.PtrFILE; + loc: Locator; + swapper: INTEGER; (* index into file table / next buffer to swap *) + len: INTEGER; + bufs: ARRAY nofbufs OF Buffer; + t: LONGINT (* time stamp of last file operation *) + END; + + Reader = POINTER TO RECORD (Files.Reader) + base: File; + org, offset: INTEGER; + buf: Buffer + END; + + Writer = POINTER TO RECORD (Files.Writer) + base: File; + org, offset: INTEGER; + buf: Buffer + END; + + Directory = POINTER TO RECORD (Files.Directory) + temp, startup: Locator + END; + + Identifier = RECORD (Kernel.Identifier) + name: FullName + END; + + Searcher = RECORD (Kernel.Identifier) + t0: INTEGER; + f: File + END; + + Counter = RECORD (Kernel.Identifier) + count: INTEGER + END; + + ShortName = ARRAY pathLen * 4 OF SHORTCHAR; + + Encoding = ARRAY 32 OF SHORTCHAR; + + VAR + MapParamString*: PROCEDURE(in, p0, p1, p2: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + dir: Directory; + wildcard: Files.Type; + startupDir: FullName; + startupLen: INTEGER; + res: INTEGER; + e, d: Iconv.iconv_t; + + (* debugging functions *) + + PROCEDURE Msg (IN str: ARRAY OF CHAR); + VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER; + BEGIN + ss := SHORT(str); + l := LEN(ss$); + ss[l] := 0AX; ss[l + 1] := 0X; + res := LinLibc.printf(ss); + res := LinLibc.fflush(0) + END Msg; + + PROCEDURE Int (x: LONGINT); + VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR; + BEGIN + IF x # MIN(LONGINT) THEN + IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 + ELSE + a := "8085774586302733229"; s[0] := "-"; k := 1; + j := 0; WHILE a[j] # 0X DO INC(j) END + END; + ASSERT(k + j < LEN(s), 20); + REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X; + Msg(s); + END Int; + + (* end of debugging functions *) + + (* encoding translation *) + + PROCEDURE GetEnc (OUT enc: Encoding; OUT ok: BOOLEAN); + VAR env: LinLibc.PtrSTR; + i, j: INTEGER; + + PROCEDURE IsSLetter (c: SHORTCHAR): BOOLEAN; + BEGIN + RETURN (c >= 'a') & (c <= 'z') + END IsSLetter; + + PROCEDURE IsBLetter (c: SHORTCHAR): BOOLEAN; + BEGIN + RETURN (c >= 'A') & (c <= 'Z') + END IsBLetter; + + PROCEDURE IsValidEncChar (x: SHORTCHAR): BOOLEAN; + BEGIN + RETURN ((x >= 'A') & (x <= 'Z')) OR ((x >= '0') & (x <= '9')) OR (x = '-') OR (x = '_') + OR ((x >= 'a') & (x <= 'z')) + END IsValidEncChar; + + BEGIN + env := LinLibc.getenv("LANG"); + IF env # NIL THEN + IF env$ = "C" THEN + enc := "ASCII"; ok := TRUE + ELSE + IF IsSLetter(env[0]) & IsSLetter(env[1]) & (env[2] = '_') + & IsBLetter(env[3]) & IsBLetter(env[4]) & (env[5] = '.') THEN + i := 6; j := 0; + WHILE IsValidEncChar(env[i]) & (j < LEN(enc) - 1) DO + enc[j] := env[i]; + INC(j); INC(i) + END; + IF (env[i] = 0X) & (j < LEN(enc)) THEN + enc[j] := 0X; ok := TRUE + ELSE ok := FALSE + END + ELSE ok := FALSE + END + END + ELSE ok := FALSE + END + END GetEnc; + + PROCEDURE InitConv; + VAR enc: Encoding; ok: BOOLEAN; + BEGIN + GetEnc(enc, ok); + IF ok THEN + IF Kernel.littleEndian THEN + e := Iconv.iconv_open(enc, "UCS-2LE"); + d := Iconv.iconv_open("UCS-2LE", enc) + ELSE + e := Iconv.iconv_open(enc, "UCS-2BE"); + d := Iconv.iconv_open("UCS-2BE", enc) + END + ELSE e := -1; d := -1 + END + END InitConv; + + PROCEDURE CloseConv; + VAR res: INTEGER; + BEGIN + IF e # -1 THEN res := Iconv.iconv_close(e); e := -1 END; + IF d # -1 THEN res := Iconv.iconv_close(d); d := -1 END + END CloseConv; + + PROCEDURE ResetCodec (c: Iconv.iconv_t): BOOLEAN; + VAR res, fLen, tLen: Iconv.size_t; + BEGIN + ASSERT(c # -1, 20); + fLen := 0; tLen := 0; + res := Iconv.iconv(c, NIL, fLen, NIL, tLen); + RETURN res # -1 + END ResetCodec; + + PROCEDURE Short (IN f: FullName; OUT t: ShortName; OUT ok: BOOLEAN); + VAR fR, fLen, tLen: INTEGER; + from: Iconv.PtrLSTR; to: Iconv.PtrSTR; res: Iconv.size_t; + BEGIN + (* do not use encoder for basic set of chars *) + fR := 0; WHILE (f[fR] >= ' ') & (f[fR] <= '~') DO t[fR] := SHORT(f[fR]); INC(fR) END; + IF f[fR] = 0X THEN t[fR] := 0X; ok := TRUE + ELSIF (e # -1) & ResetCodec(e) THEN + from := f; to := t; fLen := LEN(f$) * SIZE(CHAR) (* 2 *); tLen := LEN(t) - 1; + res := Iconv.iconv_encode(e, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE + END + ELSE t[0] := 0X; ok := FALSE + END + END Short; + + PROCEDURE Long (IN f: ShortName; OUT t: FullName; OUT ok: BOOLEAN); + VAR fR, fLen, tLen: INTEGER; + from: Iconv.PtrSTR; to: Iconv.PtrLSTR; res: Iconv.size_t; + BEGIN + (* do not use decoder for basic set of chars *) + fR := 0; WHILE (f[fR] >= ' ') & (f[fR] <= '~') & (fR < LEN(t) - 1) DO t[fR] := f[fR]; INC(fR) END; + IF f[fR] = 0X THEN + IF fR < LEN(t) THEN t[fR] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE (* f is too long *) + END + ELSIF (d # -1) & ResetCodec(d) THEN + from := f; to := t; fLen := LEN(f$); tLen := (LEN(t) - 1) * SIZE(CHAR) (* 2 *); + res := Iconv.iconv_decode(d, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE + END + ELSE t[0] := 0X; ok := FALSE + END + END Long; + + (* end of encoding translation *) + + + (* get error num from linux *) + PROCEDURE LinLibc_errno (): INTEGER; + VAR + addr, errno: INTEGER; + BEGIN + addr := LinLibc.__errno_location(); + SYSTEM.GET(addr, errno); + RETURN errno + END LinLibc_errno; + + PROCEDURE Error (n: INTEGER): INTEGER; + VAR res: INTEGER; + BEGIN + IF n = ok THEN res := ok + ELSIF n = invalidNameErr THEN res := invalidName + ELSIF (n = fileNotFoundErr) OR (n = pathNotFoundErr) THEN res := notFound + ELSIF (n = fileExistsErr) OR (n = alreadyExistsErr) THEN res := existsAlready + ELSIF n = writeProtectedErr THEN res := writeProtected + ELSIF (n = sharingErr) OR (n = accessDeniedErr) OR (n = netAccessDeniedErr) THEN res := accessDenied + ELSIF n = notEnoughMemoryErr THEN res := notEnoughMem + ELSIF (n = diskFullErr) OR (n = tooManyOpenFilesErr) THEN res := notEnoughDisk + ELSE res := -n + END; + RETURN res + END Error; + + PROCEDURE Diff (IN a, b: ARRAY OF CHAR; caseSens: BOOLEAN): INTEGER; + VAR i: INTEGER; cha, chb: CHAR; + BEGIN + i := 0; + REPEAT + cha := a[i]; chb := b[i]; INC(i); + IF cha # chb THEN + IF ~caseSens THEN + IF (cha >= "a") & ((cha <= "z") OR (cha >= 0E0X) & (cha <= 0FEX) & (cha # 0F7X)) THEN + cha := CAP(cha) + END; + IF (chb >= "a") & ((chb <= "z") OR (chb >= 0E0X) & (chb <= 0FEX) & (chb # 0F7X)) THEN + chb := CAP(chb) + END + END; + IF cha = "\" THEN cha := "/" END; + IF chb = "\" THEN chb := "/" END; + IF cha # chb THEN RETURN ORD(cha) - ORD(chb) END + END + UNTIL cha = 0X; + RETURN 0 + END Diff; + + PROCEDURE Stat (IN fname: FullName; VAR buf: LinLibc.stat_t; OUT res: INTEGER); + VAR s: ShortName; ok1: BOOLEAN; + BEGIN + Short(fname, s, ok1); + res := LinLibc.__xstat(3, s, buf); (* macro expansion of "stat" *) + END Stat; + + PROCEDURE ModeToAttr (mode: SET; OUT attr: SET; OUT isDir: BOOLEAN); + CONST read = 8; write = 7; execute = 6; file = 15; (* bits for permissions for the current user (see man chmod) *) + BEGIN + attr := {}; + IF ~(write IN mode) THEN INCL(attr, Files.readOnly) END; + isDir := ~(file IN mode) (* see "man 2 stat" for details *) + END ModeToAttr; + + PROCEDURE NewLocator* (IN fname: ARRAY OF CHAR): Locator; + VAR loc: Locator; i: INTEGER; + BEGIN + NEW(loc); loc.path := fname$; i := 0; + WHILE loc.path[i] # 0X DO INC(i) END; + IF (loc.path[i-1] = "/") OR (loc.path[i-1] = "\") THEN loc.path[i-1] := 0X END; + loc.maxLen := LinLibc.NAME_MAX; loc.caseSens := TRUE; + RETURN loc + END NewLocator; + + PROCEDURE GetType (IN name: ARRAY OF CHAR; VAR type: Files.Type); + VAR i, j: INTEGER; ch: CHAR; + BEGIN + i := 0; j := 0; + WHILE name[i] # 0X DO INC(i) END; + WHILE (i > 0) & (name[i] # ".") DO DEC(i) END; + IF i > 0 THEN + INC(i); ch := name[i]; + WHILE (j < LEN(type) - 1) & (ch # 0X) DO + IF (ch >= "A") & (ch <= "Z") THEN ch := CHR(ORD(ch) + (ORD("a") - ORD("A"))) END; + type[j] := ch; INC(j); + INC(i); ch := name[i] + END + END; + type[j] := 0X + END GetType; + + PROCEDURE Append (IN path, name: ARRAY OF CHAR; type: Files.Type; max: INTEGER; + VAR res: ARRAY OF CHAR + ); + VAR i, j, n, m, dot: INTEGER; ch: CHAR; + BEGIN + i := 0; + WHILE path[i] # 0X DO res[i] := path[i]; INC(i) END; + IF path # "" THEN + ASSERT((res[i-1] # "/") & (res[i-1] # "\"), 100); + res[i] := "/"; INC(i) + END; + j := 0; ch := name[0]; n := 0; m := max; dot := -1; + IF max = 12 THEN m := 8 END; + WHILE (i < LEN(res) - 1) & (ch # 0X) DO + IF (ch = "/") OR (ch = "\") THEN + res[i] := ch; INC(i); n := 0; m := max; dot := -1; + IF max = 12 THEN m := 8 END + ELSIF (n < m) OR (ch = ".") & (n = 8) THEN + res[i] := ch; INC(i); INC(n); + IF ch = "." THEN dot := n; + IF max = 12 THEN m := n + 3 END + END + END; + INC(j); ch := name[j] + END; + IF (dot = -1) & (type # "") THEN + IF max = 12 THEN m := n + 4 END; + IF (n < m) & (i < LEN(res) - 1) THEN res[i] := "."; INC(i); INC(n); dot := n END + END; + IF n = dot THEN j := 0; + WHILE (n < m) & (i < LEN(res) - 1) & (type[j] # 0X) DO res[i] := type[j]; INC(i); INC(j) END + END; + res[i] := 0X + END Append; + + PROCEDURE CloseFileHandle (f: File; VAR res: INTEGER); + BEGIN + IF (f.ref = invalid) OR (LinLibc.fclose(f.ref) = 0) THEN res := ok (* !!! *) + ELSE res := LinLibc_errno() + END; + f.ref := invalid + END CloseFileHandle; + + PROCEDURE CloseFile (f: File; VAR res: INTEGER); + VAR s: INTEGER; n: ShortName; ok1: BOOLEAN; + BEGIN + IF f.state = exclusive THEN + f.Flush; + res := LinLibc.fflush(f.ref) + END; + s := f.state; f.state := closed; + CloseFileHandle (f, res); + IF (s IN {temp, new, hidden}) & (f.name # "") THEN + Short(f.name, n, ok1); + res := LinLibc.remove(n) + END + END CloseFile; + + PROCEDURE (f: File) FINALIZE; + VAR res: INTEGER; + BEGIN + IF f.state # closed THEN CloseFile(f, res) END + END FINALIZE; + + PROCEDURE (VAR id: Identifier) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := id.obj(File); + RETURN (f.state IN {shared, exclusive}) & (Diff(f.name, id.name, f.loc.caseSens) = 0) + END Identified; + + PROCEDURE ThisFile (IN name: FullName): File; + VAR id: Identifier; p: ANYPTR; + BEGIN + id.typ := SYSTEM.TYP(File); id.name := name$; + p := Kernel.ThisFinObj(id); + IF p # NIL THEN RETURN p(File) + ELSE RETURN NIL + END + END ThisFile; + + PROCEDURE (VAR s: Searcher) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := s.obj(File); + IF (f.ref # invalid) & ((s.f = NIL) OR (f.t < s.f.t)) THEN s.f := f END; + RETURN FALSE + END Identified; + + PROCEDURE SearchFileToClose; + VAR s: Searcher; p: ANYPTR; (* res: LONGINT; *) + BEGIN + s.typ := SYSTEM.TYP(File); s.f := NIL; + p := Kernel.ThisFinObj(s); + IF s.f # NIL THEN + res := LinLibc.fclose(s.f.ref); s.f.ref := invalid; + IF res = 0 THEN res := LinLibc_errno(); HALT(100) END + END + END SearchFileToClose; + + PROCEDURE ExistingFile (VAR n: ShortName): BOOLEAN; + VAR f: LinLibc.PtrFILE; ret: BOOLEAN; res: INTEGER; + BEGIN + f := LinLibc.fopen(n, "r"); + IF f # LinLibc.NULL THEN + res := LinLibc.fclose(f); + ret := TRUE + ELSE + ret := FALSE + END; + RETURN ret + END ExistingFile; + + PROCEDURE MoveFile (VAR old, new: ShortName; VAR res: INTEGER); (* as the WinApi.MoveFile *) + BEGIN + IF ExistingFile(new) THEN + res := fileExistsErr + ELSE + IF LinLibc.rename(old, new) = 0 THEN res := ok + ELSE res := LinLibc_errno(); + END + END + END MoveFile; + + PROCEDURE NewFileRef (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER); + VAR n: ShortName; ok1: BOOLEAN; + BEGIN + Short(name, n, ok1); + IF state = create THEN (* Create should fail if file already exists *) + IF ExistingFile(n) THEN + ref := invalid; res := fileExistsErr + ELSE + ref := LinLibc.fopen(n, "w+"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + END + ELSIF state = shared THEN + ref := LinLibc.fopen(n, "r"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + ELSE + ref := LinLibc.fopen(n, "r+"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + END + END NewFileRef; + + PROCEDURE OpenFile (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER); + BEGIN + NewFileRef(state, name, ref, res); + IF ref = invalid THEN + IF res = tooManyOpenFilesErr THEN + Kernel.Collect; + NewFileRef(state, name, ref, res); + IF ref = invalid THEN + res := LinLibc_errno(); + IF res = tooManyOpenFilesErr THEN + SearchFileToClose; + NewFileRef(state, name, ref, res); + END + ELSE res := ok + END + END + ELSE res := ok + END + END OpenFile; + + PROCEDURE GetTempFileName (IN path: FullName; OUT name: FullName; num: INTEGER); + VAR i: INTEGER; str: ARRAY 16 OF CHAR; + BEGIN + str := tempName; i := 7; + WHILE i > 2 DO + str[i] := CHR(num MOD 10 + ORD("0")); DEC(i); num := num DIV 10 + END; + Append(path, str, "", 8, name) + END GetTempFileName; + + PROCEDURE CreateFile (f: File; VAR res: INTEGER); + VAR num, n: INTEGER; + BEGIN + IF f.name = "" THEN + num := LinLibc.clock(); n := 200; + REPEAT + GetTempFileName(f.loc.path, f.name, num); INC(num); DEC(n); + OpenFile(create, f.name, f.ref, res) + UNTIL (res # fileExistsErr) OR (n = 0) + ELSE + OpenFile(f.state, f.name, f.ref, res) + END + END CreateFile; + + PROCEDURE Delete (IN fname, path: FullName; VAR res: INTEGER); + VAR num, n: INTEGER; f: File; new: FullName; attr: SET; fn, nn: ShortName; buf: LinLibc.stat_t; isDir: BOOLEAN; + ok1: BOOLEAN; + BEGIN + ASSERT(fname # "", 100); + f := ThisFile(fname); Short(fname, fn, ok1); + IF f = NIL THEN + IF LinLibc.remove(fn) = 0 THEN + res := ok + ELSE + res := LinLibc.fflush(0); + IF LinLibc.remove(fn) = 0 THEN res := ok ELSE res := LinLibc_errno() END + END + ELSE (* still in use => make it anonymous *) + IF f.ref # invalid THEN res := LinLibc.fclose(f.ref); f.ref := invalid END; (* !!! *) + Stat(f.name, buf, res); + ModeToAttr(buf.st_mode, attr, isDir); + IF (res = ok) & ~(Files.readOnly IN attr) THEN + num := LinLibc.clock(); n := 200; + REPEAT + GetTempFileName(path, new, num); INC(num); DEC(n); + Short(new, nn, ok1); + MoveFile(fn, nn, res); + UNTIL (res # fileExistsErr) OR (n = 0); + IF res = ok THEN + f.state := hidden; f.name := new$ + END + ELSE + res := writeProtectedErr + END + END + END Delete; + + PROCEDURE FlushBuffer (f: File; i: INTEGER); + VAR buf: Buffer; res: INTEGER; + BEGIN + buf := f.bufs[i]; + IF (buf # NIL) & buf.dirty THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + res := LinLibc.fseek(f.ref, buf.org, LinLibc.SEEK_SET); + IF LinLibc.fwrite(SYSTEM.ADR(buf.data), 1, buf.len, f.ref) < buf.len THEN + res := LinLibc_errno(); HALT(101) + END; + res := LinLibc.fflush(f.ref); + buf.dirty := FALSE; f.t := Kernel.Time() + END + END + END FlushBuffer; + + (* File *) + + PROCEDURE (f: File) NewReader (old: Files.Reader): Files.Reader; + VAR r: Reader; + BEGIN (* portable *) + ASSERT(f.state # closed, 20); + IF (old # NIL) & (old IS Reader) THEN r := old(Reader) ELSE NEW(r) END; + IF r.base # f THEN + r.base := f; r.buf := NIL; r.SetPos(0) + END; + r.eof := FALSE; + RETURN r + END NewReader; + + PROCEDURE (f: File) NewWriter (old: Files.Writer): Files.Writer; + VAR w: Writer; + BEGIN (* portable *) + ASSERT(f.state # closed, 20); ASSERT(f.state # shared, 21); + IF (old # NIL) & (old IS Writer) THEN w := old(Writer) ELSE NEW(w) END; + IF w.base # f THEN + w.base := f; w.buf := NIL; w.SetPos(f.len) + END; + RETURN w + END NewWriter; + + PROCEDURE (f: File) Length (): INTEGER; + BEGIN (* portable *) + RETURN f.len + END Length; + + PROCEDURE (f: File) Flush; + VAR i: INTEGER; + BEGIN (* portable *) + i := 0; WHILE i # nofbufs DO FlushBuffer(f, i); INC(i) END + END Flush; + + PROCEDURE GetPath (IN fname: FullName; OUT path: FullName); + VAR i: INTEGER; + BEGIN + path := fname$; i := LEN(path$); + WHILE (i > 0) & (path[i] # "\") & (path[i] # "/") & (path[i-1] # ":") DO DEC(i) END; + path[i] := 0X + END GetPath; + + PROCEDURE CreateDir (VAR path: FullName; VAR res: INTEGER); + VAR (*sec: KERNEL32.SecurityAttributes;*) p: FullName; s: ShortName; ok1: BOOLEAN; + BEGIN + ASSERT(path # "", 100); + Short(path, s, ok1); + res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *) + IF res # ok THEN + res := LinLibc_errno(); + IF (res = LinLibc.ENOTDIR) OR (res = LinLibc.ENOENT) THEN + GetPath(path, p); + CreateDir(p, res); (* recursive call *) + IF res = ok THEN + res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *) + IF res # ok THEN res := LinLibc_errno() END + END + END + END + END CreateDir; + + PROCEDURE CheckPath (VAR path: FullName; ask: BOOLEAN; VAR res: INTEGER); + VAR s: ARRAY 300 OF CHAR; t: ARRAY 32 OF CHAR; + BEGIN + (*IF ask THEN + IF MapParamString # NIL THEN + MapParamString("#Host:CreateDir", path, "", "", s); + MapParamString("#Host:MissingDirectory", "", "", "", t) + ELSE + s := path$; t := "Missing Directory" + END; + res := Kernel.MessageBox(t, s, {Kernel.mbOk, Kernel.mbCancel}) + ELSE + res := Kernel.mbOk + END;*) + (*IF res = Kernel.mbOk THEN*) CreateDir(path, res) + (*ELSIF res = Kernel.mbCancel THEN res := cancel + END*) + END CheckPath; + + PROCEDURE CheckDelete (IN fname, path: FullName; ask: BOOLEAN; VAR res: INTEGER); + VAR s: ARRAY 300 OF CHAR; t: ARRAY 16 OF CHAR; + BEGIN + REPEAT + Delete(fname, path, res); + IF (res = writeProtectedErr) + OR (res = sharingErr) + OR (res = accessDeniedErr) + OR (res = netAccessDeniedErr) + THEN + (*IF ask THEN + IF MapParamString # NIL THEN + IF res = writeProtectedErr THEN + MapParamString("#Host:ReplaceWriteProtected", fname, 0DX, "", s) + ELSIF (res = accessDeniedErr) OR (res = netAccessDeniedErr) THEN + MapParamString("#Host:ReplaceAccessDenied", fname, 0DX, "", s) + ELSE + MapParamString("#Host:ReplaceInUse", fname, 0DX, "", s) + END; + MapParamString("#Host:FileError", "", "", "", t) + ELSE + s := fname$; t := "File Error" + END; + res := Kernel.MessageBox(t, s, {Kernel.mbRetry, Kernel.mbCancel}); + IF res = Kernel.mbCancel THEN res := cancel + ELSIF res = Kernel.mbRetry THEN res := retry + END + ELSE*) + res := cancel + (*END*) + ELSE + res := ok + END + UNTIL res # retry + END CheckDelete; + + PROCEDURE (f: File) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER); + VAR b: INTEGER; fname: FullName; fn, nn: ShortName; ok1: BOOLEAN; + BEGIN + ASSERT(f.state = new, 20); ASSERT(name # "", 21); + Append(f.loc.path, name, type, f.loc.maxLen, fname); + CheckDelete(fname, f.loc.path, ask, res); + ASSERT(res # 87, 100); + IF res = ok THEN + IF f.name = "" THEN + f.name := fname$; + OpenFile(create, f.name, f.ref, res); + IF res = ok THEN + f.state := exclusive; CloseFile(f, res); + Short(f.name, fn, ok1); + END + ELSE + f.state := exclusive; CloseFile(f, res); + Short(f.name, fn, ok1); Short(fname, nn, ok1); + MoveFile(fn, nn, res); + IF res = ok THEN + f.name := fname$; + Short(f.name, fn, ok1); + ELSE + ASSERT(res # 87, 101); + Short(f.name, fn, ok1); + b := LinLibc.remove(fn); + END + END + END; + res := Error(res) + END Register; + + PROCEDURE (f: File) Close; + VAR res: INTEGER; + BEGIN (* portable *) + IF f.state # closed THEN +(* + IF f.state = exclusive THEN + CloseFile(f, res) + ELSE + CloseFileHandle(f, res) + END +*) + CloseFile(f, res) + END + END Close; + + + (* Locator *) + + PROCEDURE (loc: Locator) This* (IN path: ARRAY OF CHAR): Locator; + VAR new: Locator; i: INTEGER; + BEGIN + IF path = "" THEN + NEW(new); new^ := loc^ + ELSIF path[0] = "/" THEN (* absolute path *) + new := NewLocator(path); + new.rootLen := 0 + ELSIF (path[0] = "\") OR (path[0] = "/") THEN + IF (path[1] = "\") OR (path[1] = "/") THEN (* network path *) + new := NewLocator(path); + new.rootLen := 0 + ELSE + NEW(new); new^ := dir.startup^; + new.res := invalidName; + RETURN new + END + ELSE + NEW(new); Append(loc.path, path, "", loc.maxLen, new.path); + i := 0; WHILE new.path[i] # 0X DO INC(i) END; + IF (new.path[i-1] = "/") OR (new.path[i-1] = "\") THEN new.path[i-1] := 0X END; + new.maxLen := loc.maxLen; + new.caseSens := loc.caseSens; + new.rootLen := loc.rootLen + END; + new.res := ok; + RETURN new + END This; + + (* Reader *) + + PROCEDURE (r: Reader) Base (): Files.File; + BEGIN (* portable *) + RETURN r.base + END Base; + + PROCEDURE (r: Reader) SetPos (pos: INTEGER); + VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer; + BEGIN + f := r.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25); + ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21); + offset := pos MOD bufsize; org := pos - offset; + i := 0; WHILE (i # nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END; + IF i # nofbufs THEN + buf := f.bufs[i]; + IF buf = NIL THEN (* create new buffer *) + NEW(buf); f.bufs[i] := buf; buf.org := -1 + END + ELSE (* choose an existing buffer *) + f.swapper := (f.swapper + 1) MOD nofbufs; + FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1 + END; + IF buf.org # org THEN + IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END; + count := buf.len; + IF count > 0 THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN + res := LinLibc_errno(); HALT(101) + END; + IF LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN + res := LinLibc_errno(); HALT(102) + END; + f.t := Kernel.Time() + END + END; + buf.org := org; buf.dirty := FALSE + END; + r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE + (* 0<= r.org <= r.base.len *) + (* 0 <= r.offset < bufsize *) + (* 0 <= r.buf.len <= bufsize *) + (* r.offset <= r.base.len *) + (* r.offset <= r.buf.len *) + END SetPos; + + PROCEDURE (r: Reader) Pos (): INTEGER; + BEGIN (* portable *) + ASSERT(r.base # NIL, 20); + RETURN r.org + r.offset + END Pos; + + PROCEDURE (r: Reader) ReadByte (OUT x: BYTE); + BEGIN (* portable *) + IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END; + IF r.offset < r.buf.len THEN + x := r.buf.data[r.offset]; INC(r.offset) + ELSE + x := 0; r.eof := TRUE + END + END ReadByte; + + PROCEDURE (r: Reader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER); + VAR from, to, count, restInBuf: INTEGER; + BEGIN (* portable *) + ASSERT(beg >= 0, 21); + IF len > 0 THEN + ASSERT(beg + len <= LEN(x), 23); + WHILE len # 0 DO + IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END; + restInBuf := r.buf.len - r.offset; + IF restInBuf = 0 THEN r.eof := TRUE; RETURN + ELSIF restInBuf <= len THEN count := restInBuf + ELSE count := len + END; + from := SYSTEM.ADR(r.buf.data[r.offset]); to := SYSTEM.ADR(x) + beg; + SYSTEM.MOVE(from, to, count); + INC(r.offset, count); INC(beg, count); DEC(len, count) + END; + r.eof := FALSE + ELSE ASSERT(len = 0, 22) + END + END ReadBytes; + + (* Writer *) + + PROCEDURE (w: Writer) Base (): Files.File; + BEGIN (* portable *) + RETURN w.base + END Base; + + PROCEDURE (w: Writer) SetPos (pos: INTEGER); + VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer; + BEGIN + f := w.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25); + ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21); + offset := pos MOD bufsize; org := pos - offset; + i := 0; WHILE (i # nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END; + IF i # nofbufs THEN + buf := f.bufs[i]; + IF buf = NIL THEN (* create new buffer *) + NEW(buf); f.bufs[i] := buf; buf.org := -1 + END + ELSE (* choose an existing buffer *) + f.swapper := (f.swapper + 1) MOD nofbufs; + FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1 + END; + IF buf.org # org THEN + IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END; + count := buf.len; + IF count > 0 THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN + res := LinLibc_errno(); HALT(101) + END; + IF LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN + res := LinLibc_errno(); HALT(102) + END; + f.t := Kernel.Time() + END + END; + buf.org := org; buf.dirty := FALSE + END; + w.buf := buf; w.org := org; w.offset := offset + (* 0<= w.org <= w.base.len *) + (* 0 <= w.offset < bufsize *) + (* 0 <= w.buf.len <= bufsize *) + (* w.offset <= w.base.len *) + (* w.offset <= w.buf.len *) + END SetPos; + + PROCEDURE (w: Writer) Pos (): INTEGER; + BEGIN (* portable *) + ASSERT(w.base # NIL, 20); + RETURN w.org + w.offset + END Pos; + + PROCEDURE (w: Writer) WriteByte (x: BYTE); + BEGIN (* portable *) + ASSERT(w.base.state # closed, 25); + IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END; + w.buf.data[w.offset] := x; w.buf.dirty := TRUE; + IF w.offset = w.buf.len THEN INC(w.buf.len); INC(w.base.len) END; + INC(w.offset) + END WriteByte; + + PROCEDURE (w: Writer) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER); + VAR from, to, count, restInBuf: INTEGER; + BEGIN (* portable *) + ASSERT(beg >= 0, 21); ASSERT(w.base.state # closed, 25); + IF len > 0 THEN + ASSERT(beg + len <= LEN(x), 23); + WHILE len # 0 DO + IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END; + restInBuf := bufsize - w.offset; + IF restInBuf <= len THEN count := restInBuf ELSE count := len END; + from := SYSTEM.ADR(x) + beg; to := SYSTEM.ADR(w.buf.data[w.offset]); + SYSTEM.MOVE(from, to, count); + INC(w.offset, count); INC(beg, count); DEC(len, count); + IF w.offset > w.buf.len THEN INC(w.base.len, w.offset - w.buf.len); w.buf.len := w.offset END; + w.buf.dirty := TRUE + END + ELSE ASSERT(len = 0, 22) + END + END WriteBytes; + + (* Directory *) + + PROCEDURE (d: Directory) This (IN path: ARRAY OF CHAR): Files.Locator; + BEGIN + RETURN d.startup.This(path) + END This; + + PROCEDURE (d: Directory) New (loc: Files.Locator; ask: BOOLEAN): Files.File; + VAR f: File; res: INTEGER; attr: SET; isDir: BOOLEAN; buf: LinLibc.stat_t; + BEGIN + ASSERT(loc # NIL, 20); f := NIL; res := ok; + WITH loc: Locator DO + IF loc.path # "" THEN + Stat(loc.path, buf, res); + IF res # ok THEN + IF loc.res = 76 THEN CreateDir(loc.path, res) + ELSE CheckPath(loc.path, ask, res) + END + ELSE + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN res := fileExistsErr END + END + END; + IF res = ok THEN + NEW(f); f.loc := loc; f.name := ""; + f.state := new; f.swapper := -1; f.len := 0; f.ref := invalid + END + ELSE res := invalidNameErr + END; + loc.res := Error(res); + RETURN f + END New; + + PROCEDURE (d: Directory) Temp (): Files.File; + VAR f: File; + BEGIN + NEW(f); f.loc := d.temp; f.name := ""; + f.state := temp; f.swapper := -1; f.len := 0; f.ref := invalid; + RETURN f + END Temp; + + PROCEDURE GetShadowDir (loc: Locator; OUT dir: FullName); + VAR i, j: INTEGER; + BEGIN + dir := startupDir$; i := startupLen; j := loc.rootLen; + WHILE loc.path[j] # 0X DO dir[i] := loc.path[j]; INC(i); INC(j) END; + dir[i] := 0X + END GetShadowDir; + + PROCEDURE (d: Directory) Old (loc: Files.Locator; name: Files.Name; shrd: BOOLEAN): Files.File; + VAR res: INTEGER; f: File; ref: LinLibc.PtrFILE; fname: FullName; type: Files.Type; s: BYTE; buf: LinLibc.stat_t; + BEGIN + ASSERT(loc # NIL, 20); ASSERT(name # "", 21); + res := ok; f := NIL; + WITH loc: Locator DO + Append(loc.path, name, "", loc.maxLen, fname); + f := ThisFile(fname); + IF f # NIL THEN + IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL + ELSE loc.res := ok; RETURN f + END + END; + IF shrd THEN s := shared ELSE s := exclusive END; + OpenFile(s, fname, ref, res); + IF ((res = fileNotFoundErr) OR (res = pathNotFoundErr)) & (loc.rootLen > 0) THEN + GetShadowDir(loc, fname); + Append(fname, name, "", loc.maxLen, fname); + f := ThisFile(fname); + IF f # NIL THEN + IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL + ELSE loc.res := ok; RETURN f + END + END; + OpenFile(s, fname, ref, res) + END; + IF res = ok THEN + NEW(f); f.loc := loc; + f.swapper := -1; + GetType(name, type); + f.InitType(type); + ASSERT(ref # invalid, 107); + f.ref := ref; f.name := fname$; f.state := s; f.t := Kernel.Time(); + Stat(f.name, buf, res); + f.len := buf.st_size; + res := LinLibc.fseek(ref, 0, LinLibc.SEEK_SET); + END + END; + loc.res := Error(res); + RETURN f + END Old; + + PROCEDURE (d: Directory) Delete* (loc: Files.Locator; name: Files.Name); + VAR res: INTEGER; fname: FullName; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + Append(loc.path, name, "", loc.maxLen, fname); + Delete(fname, loc.path, res) + ELSE res := invalidNameErr + END; + loc.res := Error(res) + END Delete; + + PROCEDURE (d: Directory) Rename* (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN); + VAR res, i: INTEGER; oldname, newname: FullName; f: File; on, nn, tn: ShortName; buf: LinLibc.stat_t; + ok1: BOOLEAN; tName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + Append(loc.path, old, "", loc.maxLen, oldname); Append(loc.path, new, "", loc.maxLen, newname); + Short(oldname, on, ok1); Short(newname, nn, ok1); + Stat(oldname, buf, res); + IF res = ok THEN + f := ThisFile(oldname); + IF (f # NIL) & (f.ref # invalid) THEN res := LinLibc.fclose(f.ref); f.ref := invalid END; + IF Diff(oldname, newname, loc.caseSens) # 0 THEN + CheckDelete(newname, loc.path, ask, res); + IF res = ok THEN + IF LinLibc.rename(on, nn) = 0 THEN + IF f # NIL THEN (* still in use => update file table *) + f.name := newname$ + END + ELSE res := LinLibc_errno() + END + END + ELSE (* destination is same file as source *) + tName := oldname; i := LEN(tName$) - 1; + REPEAT + tName[i] := CHR(ORD(tName[i]) + 1); + Short(tName, tn, ok1); + MoveFile(on, tn, res); + UNTIL (res # fileExistsErr) & (res # alreadyExistsErr) & (res # 87); + IF res = ok THEN + MoveFile(tn, nn, res) + END + END + ELSE res := fileNotFoundErr + END + ELSE res := invalidNameErr + END; + loc.res := Error(res) + END Rename; + + PROCEDURE (d: Directory) SameFile* (loc0: Files.Locator; name0: Files.Name; + loc1: Files.Locator; name1: Files.Name + ): BOOLEAN; + VAR p0, p1: FullName; + BEGIN + ASSERT(loc0 # NIL, 20); ASSERT(loc1 # NIL, 21); + WITH loc0: Locator DO Append(loc0.path, name0, "", loc0.maxLen, p0) END; + WITH loc1: Locator DO Append(loc1.path, name1, "", loc1.maxLen, p1) END; + RETURN Diff(p0, p1, loc0(Locator).caseSens) = 0 + END SameFile; + + PROCEDURE (d: Directory) FileList* (loc: Files.Locator): Files.FileInfo; + VAR diff, res: INTEGER; first, last, info: Files.FileInfo; s: FullName; + ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t; tm: LinLibc.tm; + isDir: BOOLEAN; attr: SET; ok1: BOOLEAN; dName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + first := NIL; last :=NIL; + WITH loc: Locator DO + Short(loc.path, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *) + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN + info := first; last := NIL; s := dName; + WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END; + NEW(info); + info.name := dName$; + GetType(info.name, info.type); + info.length := buf.st_size; + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + info.modified.year := tm.tm_year + 1900; + info.modified.month := tm.tm_mon + 1; + info.modified.day := tm.tm_mday; + info.modified.hour := tm.tm_hour; + info.modified.minute := tm.tm_min; + info.modified.second := tm.tm_sec + END; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END; + (* check startup directory *) + IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN + GetShadowDir(loc, s); + Short(s, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *) + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN + info := first; last := NIL; s := dName; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END; + WHILE (info # NIL) & (diff < 0) DO + last := info; info := info.next; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END + END; + IF (info = NIL) OR (diff # 0) THEN + NEW(info); + info.name := dName$; + GetType(info.name, info.type); + info.length := buf.st_size; + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + info.modified.year := tm.tm_year + 1900; + info.modified.month := tm.tm_mon + 1; + info.modified.day := tm.tm_mday; + info.modified.hour := tm.tm_hour; + info.modified.minute := tm.tm_min; + info.modified.second := tm.tm_sec + END; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END + END; + loc.res := Error(res) + ELSE loc.res := invalidName + END; + RETURN first + END FileList; + + PROCEDURE (d: Directory) LocList* (loc: Files.Locator): Files.LocInfo; + VAR diff, res: INTEGER; first, last, info: Files.LocInfo; s: FullName; isDir: BOOLEAN; attr: SET; + ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t; + ok1: BOOLEAN; dName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + first := NIL; last :=NIL; + WITH loc: Locator DO + Short(loc.path, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *) + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN + info := first; last := NIL; s := dName; + WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END; + NEW(info); + info.name := dName$; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END; + (* check startup directory *) + IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN + GetShadowDir(loc, s); + Short(s, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.__xstat(3, fname, buf); (* macro expansion of "stat" *) + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN + info := first; last := NIL; s := dName; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END; + WHILE (info # NIL) & (diff < 0) DO + last := info; info := info.next; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END + END; + IF (info = NIL) OR (diff # 0) THEN + NEW(info); + info.name := dName$; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END + END; + loc.res := Error(res) + ELSE loc.res := invalidName + END; + RETURN first + END LocList; + + PROCEDURE (d: Directory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name); + BEGIN + Append("", name, type, LEN(filename), filename) + END GetFileName; + + (** Miscellaneous **) + + PROCEDURE (VAR id: Counter) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := id.obj(File); + IF f.state # closed THEN INC(id.count) END; + RETURN FALSE + END Identified; + + PROCEDURE NofFiles* (): INTEGER; + VAR p: ANYPTR; cnt: Counter; + BEGIN + cnt.typ := SYSTEM.TYP(File); + cnt.count := 0; p := Kernel.ThisFinObj(cnt); + RETURN cnt.count + END NofFiles; + + PROCEDURE GetModDate* (f: Files.File; VAR year, month, day, hour, minute, second: INTEGER); + VAR buf: LinLibc.stat_t; tm: LinLibc.tm; + BEGIN + ASSERT(f IS File, 20); + Stat(f(File).name, buf, res); + IF res = ok THEN + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + year := tm.tm_year + 1900; month := tm.tm_mon + 1; day := tm.tm_mday; + hour := tm.tm_hour; minute := tm.tm_min; second := tm.tm_sec + ELSE + res := -1 + END + END; + IF res # ok THEN year := 0; month := 0; day := 0; hour := 0; minute := 0; second := 0 END + END GetModDate; + + PROCEDURE SetRootDir* (path: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + dir.startup := NewLocator(path); + dir.startup.rootLen := 0; i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i + END SetRootDir; + +(* + PROCEDURE GetName (VAR p: ARRAY OF CHAR; VAR i: INTEGER; OUT name, opt: FullName); + VAR ch, tch: CHAR; j: INTEGER; + BEGIN + j := 0; ch := p[i]; tch := " "; + WHILE ch = " " DO INC(i); ch := p[i] END; + IF (ch = "'") OR (ch = '"') THEN tch := ch; INC(i); ch := p[i] END; + WHILE (ch >= " ") & (ch # tch) DO + name[j] := ch; + IF (ch >= "a") & (ch <= "z") OR (ch >= "à") & (ch <= "ö") OR (ch >= "ø") & (ch <= "þ") THEN ch := CAP(ch) + ELSIF ch = "-" THEN ch := "/" + END; + opt[j] := ch; INC(j); INC(i); ch := p[i] + END; + IF ch > " " THEN INC(i); ch := p[i] END; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := p[i] END; + name[j] := 0X; opt[j] := 0X + END GetName; + + PROCEDURE Init; + VAR res, i, slp: INTEGER; path, opt: FullName; attr: SET; p: LinLibc.PtrSTR; str: ARRAY 256 OF CHAR; + buf: LinLibc.stat_t; isDir: BOOLEAN; + BEGIN +(* + TODO: + Instead of using getcwd below to find the local path it would be better to use Kernel.bootinfo.argv[0]. + But this only works if the PATH variable of the shell is not set to hold the BlackBox directory. In that + case all directories in the PATH variable has to be searched for the blackbox executable: + if (argv[0][0] == '/') + s = argv[0] + else { + str = getenv( "PATH" ); len = strlen( str ); + for ( i = 0, s = 0; i < len; i++ ) + if ( str[i] == ':' ) { + str[i] = '\0'; + if ( checkpath( str + s, argv[0] ) ) break; + else s = i + 1; + } + } +*) + wildcard := "*"; NEW(dir); + str := Kernel.cmdLine$; + i := 0; slp := -1; + WHILE (str[i] # " ") & (str[i] # 0X) DO + startupDir[i] := str[i]; + IF str[i] = "/" THEN slp := i END; + INC(i) + END; + startupDir[i] := 0X; + IF slp < 0 THEN + appName := startupDir; + p := NIL; + p := LinLibc.getcwd(p, 0); + startupDir := p$; + LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)); + i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i; + ELSE + i := slp + 1; + WHILE startupDir[i] # 0X DO appName[i - slp - 1] := startupDir[i]; INC(i) END; + startupDir[slp] := 0X; + startupLen := slp; + END; + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; +(* + p := NIL; + p := LinLibc.getcwd(p, 0); + startupDir := p$; LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)); + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i; + str := Kernel.cmdLine$; +*) +(* + i := 0; + WHILE (str[i] # " ") & (str[i] # 0X) DO appName[i] := str[i]; INC(i) END; + appName[i] := 0X; +*) + i := 0; res := 1; + REPEAT + GetName(str, i, path, opt); + IF opt = "/USE" THEN + GetName(str, i, path, opt); + Stat(path, buf, res); + IF res =ok THEN + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN res := ok ELSE res := invalidName END + END + END + UNTIL (res = 0) OR (str[i] < " "); + IF serverVersion & (res = 0) THEN + i := 0; WHILE path[i] # 0X DO INC(i) END; + IF (path[i-1] = "/") OR (path[i-1] = "\") THEN DEC(i); path[i] := 0X END; + dir.startup := NewLocator(path); + dir.startup.rootLen := SHORT(i) + END; + dir.temp := NewLocator(LinLibc.P_tmpdir); + Files.SetDir(dir) + END Init; +*) + + PROCEDURE Init; + CONST bbServerDir = "BB_PRIMARY_DIR"; bbWorkDir = "BB_SECONDARY_DIR"; + VAR res: INTEGER; attr: SET; p: LinLibc.PtrSTR; + buf: LinLibc.stat_t; isDir, def1: BOOLEAN; + ok1: BOOLEAN; fname: FullName; + BEGIN + InitConv; + + wildcard := "*"; NEW(dir); + + p := LinLibc.getenv(bbServerDir); (* p = NIL -> undefined *) + def1 := FALSE; + IF p # NIL THEN + Long(p$, fname, ok1); + IF ok1 THEN + Stat(fname, buf, res); + IF res = ok THEN + ModeToAttr(buf.st_mode, attr, isDir); + def1 := isDir + END + END; + IF ~def1 THEN Msg("HostFiles: Value of " + bbServerDir + " isn't directory, using cwd") END + END; + IF ~def1 THEN + p := NIL; + p := LinLibc.getcwd(p, 0); + Long(p$, fname, ok1); + IF ~ok1 THEN fname := "." END; + LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)) + END; + startupDir := fname; startupLen := LEN(startupDir$); + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; + + p := LinLibc.getenv(bbWorkDir); (* p = NIL -> undefined *) + IF def1 & (p # NIL) THEN + Long(p$, fname, ok1); + IF ok1 THEN + Stat(fname, buf, res); + ok1 := res = ok; + IF ok1 THEN + ModeToAttr(buf.st_mode, attr, isDir); + ok1 := isDir + END + END; + IF ~serverVersion THEN + (* - *) + ELSIF ok1 THEN + dir.startup := NewLocator(fname); dir.startup.rootLen := LEN(fname$) + ELSE + Msg("HostFiles: Value of " + bbWorkDir + " isn't directory, server configuration isn't enabled") + END + END; + + dir.temp := NewLocator(LinLibc.P_tmpdir); + Files.SetDir(dir) + END Init; + +BEGIN + Init +CLOSE + CloseConv +END HostFiles. diff --git a/Trurl-based/_Linux_/Lin/Mod/Dl.odc b/Trurl-based/_Linux_/Lin/Mod/Dl.odc new file mode 100644 index 0000000..e95f2fa Binary files /dev/null and b/Trurl-based/_Linux_/Lin/Mod/Dl.odc differ diff --git a/Trurl-based/_Linux_/Lin/Mod/Dl.txt b/Trurl-based/_Linux_/Lin/Mod/Dl.txt new file mode 100644 index 0000000..0bfc543 --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Mod/Dl.txt @@ -0,0 +1,30 @@ +MODULE LinDl ["libdl.so.2"]; + + (* THIS IS TEXT COPY OF OpenBUGS Lin/Mod/Dl.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM; + + CONST + (* dlOpen mode parameters *) + RTLD_LAZY* = 01H; (* Lazy function call binding. *) + RTLD_NOW* = 02H; (* Immediate function call binding. *) + RTLD_BINDING_MASK* = 03H; (* Mask of binding time value. *) + RTLD_NOLOAD* = 04H; (* Do not load the object. *) + RTLD_LOCAL* = 0; + RTLD_GLOBAL* = 100H; + RTDL_NODELETE* = 1000H; + + NULL* = 0; + + TYPE + PtrVoid* = INTEGER; + HANDLE* = PtrVoid; + PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + PROCEDURE [ccall] dlopen* (file: PtrSTR; mode: INTEGER): HANDLE; + PROCEDURE [ccall] dlsym* (handle: HANDLE; name: PtrSTR): HANDLE; + PROCEDURE [ccall] dlclose* (handle: HANDLE): INTEGER; + PROCEDURE [ccall] dlerror* (): PtrSTR; + +END LinDl. \ No newline at end of file diff --git a/Trurl-based/_Linux_/Lin/Mod/Iconv.odc b/Trurl-based/_Linux_/Lin/Mod/Iconv.odc new file mode 100644 index 0000000..f415a24 Binary files /dev/null and b/Trurl-based/_Linux_/Lin/Mod/Iconv.odc differ diff --git a/Trurl-based/_Linux_/Lin/Mod/Iconv.txt b/Trurl-based/_Linux_/Lin/Mod/Iconv.txt new file mode 100644 index 0000000..2a87e83 --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Mod/Iconv.txt @@ -0,0 +1,22 @@ +MODULE LinIconv ["libc.so.6"]; + + IMPORT Libc := LinLibc; + + TYPE + PtrVoid = Libc.PtrVoid; + PtrSTR* = Libc.PtrSTR; + PtrLSTR* = POINTER TO ARRAY [untagged] OF CHAR; + size_t* = Libc.size_t; + + iconv_t* = PtrVoid; + + PROCEDURE [ccall] iconv_open* (tocode, fromcode: PtrSTR): iconv_t; + PROCEDURE [ccall] iconv_close* (cd: iconv_t): INTEGER; + + PROCEDURE [ccall] iconv* (cd: iconv_t; VAR [nil] inbuf: PtrSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrSTR; VAR outbytesleft: size_t): size_t; + + PROCEDURE [ccall] iconv_encode* ["iconv"] (cd: iconv_t; VAR [nil] inbuf: PtrLSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrSTR; VAR outbytesleft: size_t): size_t; + + PROCEDURE [ccall] iconv_decode* ["iconv"] (cd: iconv_t; VAR [nil] inbuf: PtrSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrLSTR; VAR outbytesleft: size_t): size_t; + +END LinIconv. diff --git a/Trurl-based/_Linux_/Lin/Mod/Libc.odc b/Trurl-based/_Linux_/Lin/Mod/Libc.odc new file mode 100644 index 0000000..4b89389 Binary files /dev/null and b/Trurl-based/_Linux_/Lin/Mod/Libc.odc differ diff --git a/Trurl-based/_Linux_/Lin/Mod/Libc.txt b/Trurl-based/_Linux_/Lin/Mod/Libc.txt new file mode 100644 index 0000000..493ea30 --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Mod/Libc.txt @@ -0,0 +1,467 @@ +MODULE LinLibc ["libc.so.6"]; + + (* THIS IS TEXT COPY OF Libc.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM; + + CONST + NULL* = 0H; + TRUE* = 1; + FALSE* = 0; + + (* file constants *) + SEEK_SET* = 0; + SEEK_CUR* = 1; + SEEK_END* = 2; + NAME_MAX* = 256; + + (* The value of CLOCKS_PER_SEC is required to be 1 million on all XSI-conformant systems.*) + CLOCKS_PER_SECOND* = 1000000; + + (* temp directory defined in stdio.h *) + P_tmpdir* = "/tmp"; + + (* signal constants *) (* Fake signal functions. *) + SIG_ERR* = -1; (* Error return. *) + SIG_DFL* = 0; (* Default action. *) + SIG_IGN* = 1; (* Ignore signal. *) + SIG_HOLD* = 2; (* Add signal to hold mask. *) + + (* Signals. *) + SIGHUP* = 1; (* Hangup (POSIX). *) + SIGINT* = 2; (* Interrupt (ANSI). *) + SIGQUIT* = 3; (* Quit (POSIX). *) + SIGILL* = 4; (* Illegal instruction (ANSI). *) + SIGTRAP* = 5; (* Trace trap (POSIX). *) + SIGABRT* = 6; (* Abort (ANSI). *) + SIGIOT* = 6; (* IOT trap (4.2 BSD). *) + SIGBUS* = 7; (* BUS error (4.2 BSD). *) + SIGFPE* = 8; (* Floating-point exception (ANSI). *) + SIGKILL* = 9; (* Kill, unblockable (POSIX). *) + SIGUSR1* = 10; (* User-defined signal 1 (POSIX). *) + SIGSEGV* = 11; (* Segmentation violation (ANSI). *) + SIGUSR2* = 12; (* User-defined signal 2 (POSIX). *) + SIGPIPE* = 13; (* Broken pipe (POSIX). *) + SIGALRM* = 14; (* Alarm clock (POSIX). *) + SIGTERM* = 15; (* Termination (ANSI). *) + SIGSTKFLT* = 16; (* Stack fault. *) + SIGCHLD* = 17; (* Child status has changed (POSIX). *) + SIGCLD* = SIGCHLD; (* Same as SIGCHLD (System V). *) + SIGCONT* = 18; (* Continue (POSIX). *) + SIGSTOP* = 19; (* Stop, unblockable (POSIX). *) + SIGTSTP* = 20; (* Keyboard stop (POSIX). *) + SIGTTIN* = 21; (* Background read from tty (POSIX). *) + SIGTTOU* = 22; (* Background write to tty (POSIX). *) + SIGURG* = 23; (* Urgent condition on socket (4.2 BSD). *) + SIGXCPU* = 24; (* CPU limit exceeded (4.2 BSD). *) + SIGXFSZ* = 25; (* File size limit exceeded (4.2 BSD). *) + SIGVTALRM* =26; (* Virtual alarm clock (4.2 BSD). *) + SIGPROF* = 27; (* Profiling alarm clock (4.2 BSD). *) + SIGWINCH* = 28; (* Window size change (4.3 BSD, Sun). *) + SIGIO* = 29; (* I/O now possible (4.2 BSD). *) + SIGPOLL* = SIGIO; (* Pollable event occurred (System V). *) + SIGPWR* = 30; (* Power failure restart (System V). *) + SIGSYS* = 31; (* Bad system call. *) + SIGUNUSED* =31; + _NSIG* = 64; (* Biggest signal number + 1 (including real-time signals). *) + __SIGRTMIN*= 32; + __SIGRTMAX*=_NSIG - 1; + + (* Bits in `sa_flags'. *) + SA_NOCLDSTOP* = {0}; (* = 1 Don't send SIGCHLD when children stop. *) + SA_NOCLDWAIT* = {1}; (* = 2 Don't create zombie on child death. *) + SA_SIGINFO* = {2}; (* = 4 Invoke signal-catching function wth three arguments instead of one. *) + SA_ONSTACK* = {27}; (* = 0x08000000 Use signal stack by using `sa_restorer'. *) + SA_RESTART* = {28}; (* = 0x10000000 Restart syscall on signal return. *) + SA_NODEFER* = {30}; (* = 0x40000000 Don't automatically block the signal when its handler is being executed. *) + SA_RESETHAND* = {31}; (* = 0x80000000 Reset to SIG_DFL on entry to handler. *) + SA_INTERRUPT* = {29}; (* = 0x20000000 Historical no-op. *) + (* Some aliases for the SA_ constants. *) + SA_NOMASK* = SA_NODEFER; + SA_ONESHOT* = SA_RESETHAND; + SA_STACK* = SA_ONSTACK; + + (* code values for siginfo_t.si_code when sig = SIGFPE *) + FPE_INTDIV* = 1; (* Integer divide by zero. *) + FPE_INTOVF* = 2; (* Integer overflow. *) + FPE_FLTDIV* = 3; (* Floating point divide by zero. *) + FPE_FLTOVF* = 4; (* Floating point overflow. *) + FPE_FLTUND* = 5; (* Floating point underflow. *) + FPE_FLTRES* =6; (* Floating point inexact result. *) + FPE_FLTINV* = 7; (* Floating point invalid operation. *) + FPE_FLTSUB* = 8; (* Subscript out of range. *) + + (* possible error constants for errno *) + EPERM* = 1; (* Operation not permitted *) + ENOENT* = 2; (* No such file or directory *) + ESRCH* = 3; (* No such process *) + EINTR* = 4; (* Interrupted system call *) + EIO* = 5; (* I/O error *) + ENXIO* = 6; (* No such device or address *) + E2BIG* = 7; (* Arg list too long *) + ENOEXEC* = 8; (* Exec format error *) + EBADF* = 9; (* Bad file number *) + ECHILD* = 10; (* No child processes *) + EAGAIN* = 11; (* Try again *) + ENOMEM* = 12; (* Out of memory *) + EACCES* = 13; (* Permission denied *) + EFAULT* = 14; (* Bad address *) + ENOTBLK* = 15; (* Block device required *) + EBUSY* = 16; (* Device or resource busy *) + EEXIST* = 17; (* File exists *) + EXDEV* = 18; (* Cross-device link *) + ENODEV* = 19; (* No such device *) + ENOTDIR* = 20; (* Not a directory *) + EISDIR* = 21; (* Is a directory *) + EINVAL* = 22; (* Invalid argument *) + ENFILE* = 23; (* File table overflow *) + EMFILE* = 24; (* Too many open files *) + ENOTTY* = 25; (* Not a typewriter *) + ETXTBSY* = 26; (* Text file busy *) + EFBIG* = 27; (* File too large *) + ENOSPC* = 28; (* No space left on device *) + ESPIPE* = 29; (* Illegal seek *) + EROFS* = 30; (* Read-only file system *) + EMLINK* = 31; (* Too many links *) + EPIPE* = 32; (* Broken pipe *) + EDOM* = 33; (* Math argument out of domain of func *) + ERANGE* = 34; (* Math result not representable *) + EDEADLK* = 35; (* Resource deadlock would occur *) + ENAMETOOLONG* = 36; (* File name too long *) + ENOLCK* = 37; (* No record locks available *) + ENOSYS* = 38; (* Function not implemented *) + ENOTEMPTY* = 39; (* Directory not empty *) + ELOOP* = 40; (* Too many symbolic links encountered *) + EWOULDBLOCK* = EAGAIN; (* Operation would block *) + ENOMSG* = 42; (* No message of desired type *) + EIDRM* = 43; (* Identifier removed *) + ECHRNG* = 44; (* Channel number out of range *) + EL2NSYNC* = 45; (* Level 2 not synchronized *) + EL3HLT* = 46; (* Level 3 halted *) + EL3RST* = 47; (* Level 3 reset *) + ELNRNG* = 48; (* Link number out of range *) + EUNATCH* = 49; (* Protocol driver not attached *) + ENOCSI* = 50; (* No CSI structure available *) + EL2HLT* = 51; (* Level 2 halted *) + EBADE* = 52; (* Invalid exchange *) + EBADR* = 53; (* Invalid request descriptor *) + EXFULL* = 54; (* Exchange full *) + ENOANO* = 55; (* No anode *) + EBADRQC* = 56; (* Invalid request code *) + EBADSLT* = 57; (* Invalid slot *) + EDEADLOCK* = EDEADLK; + EBFONT* = 59; (* Bad font file format *) + ENOSTR* = 60; (* Device not a stream *) + ENODATA* = 61; (* No data available *) + ETIME* = 62; (* Timer expired *) + ENOSR* = 63; (* Out of streams resources *) + ENONET* = 64; (* Machine is not on the network *) + ENOPKG* = 65; (* Package not installed *) + EREMOTE* = 66; (* Object is remote *) + ENOLINK* = 67; (* Link has been severed *) + EADV* = 68; (* Advertise error *) + ESRMNT* = 69; (* Srmount error *) + ECOMM* = 70; (* Communication error on send *) + EPROTO* = 71; (* Protocol error *) + EMULTIHOP* = 72; (* Multihop attempted *) + EDOTDOT* = 73; (* RFS specific error *) + EBADMSG* = 74; (* Not a data message *) + EOVERFLOW* = 75; (* Value too large for defined data type *) + ENOTUNIQ* = 76; (* Name not unique on network *) + EBADFD* = 77; (* File descriptor in bad state *) + EREMCHG* = 78; (* Remote address changed *) + ELIBACC* = 79; (* Can not access a needed shared library *) + ELIBBAD* = 80; (* Accessing a corrupted shared library *) + ELIBSCN* = 81; (* .lib section in a.out corrupted *) + ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) + ELIBEXEC* = 83; (* Cannot exec a shared library directly *) + EILSEQ* = 84; (* Illegal byte sequence *) + ERESTART* = 85; (* Interrupted system call should be restarted *) + ESTRPIPE* = 86; (* Streams pipe error *) + EUSERS* = 87; (* Too many users *) + ENOTSOCK* = 88; (* Socket operation on non-socket *) + EDESTADDRREQ* = 89; (* Destination address required *) + EMSGSIZE* = 90; (* Message too long *) + EPROTOTYPE* = 91; (* Protocol wrong type for socket *) + ENOPROTOOPT* = 92; (* Protocol not available *) + EPROTONOSUPPORT* = 93; (* Protocol not supported *) + ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) + EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) + EPFNOSUPPORT* = 96; (* Protocol family not supported *) + EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) + EADDRINUSE* = 98; (* Address already in use *) + EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) + ENETDOWN* = 100; (* Network is down *) + ENETUNREACH* = 101; (* Network is unreachable *) + ENETRESET* = 102; (* Network dropped connection because of reset *) + ECONNABORTED* = 103; (* Software caused connection abort *) + ECONNRESET* = 104; (* Connection reset by peer *) + ENOBUFS* = 105; (* No buffer space available *) + EISCONN* = 106; (* Transport endpoint is already connected *) + ENOTCONN* = 107; (* Transport endpoint is not connected *) + ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) + ETOOMANYREFS* = 109; (* Too many references: cannot splice *) + ETIMEDOUT* = 110; (* Connection timed out *) + ECONNREFUSED* = 111; (* Connection refused *) + EHOSTDOWN* = 112; (* Host is down *) + EHOSTUNREACH* = 113; (* No route to host *) + EALREADY* = 114; (* Operation already in progress *) + EINPROGRESS* = 115; (* Operation now in progress *) + ESTALE* = 116; (* Stale NFS file handle *) + EUCLEAN* = 117; (* Structure needs cleaning *) + ENOTNAM* = 118; (* Not a XENIX named type file *) + ENAVAIL* = 119; (* No XENIX semaphores available *) + EISNAM* = 120; (* Is a named type file *) + EREMOTEIO* = 121; (* Remote I/O error *) + EDQUOT* = 122; (* Quota exceeded *) + ENOMEDIUM* = 123; (* No medium found *) + EMEDIUMTYPE* = 124; (* Wrong medium type *) + + PROT_NONE* = {}; (* No access *) + PROT_READ* = {2}; (* Pages can be read *) + PROT_WRITE* = {1}; (* Pages can be written *) + PROT_EXEC* = {0}; (* Pages can be executed *) + MAP_FILE* = {0}; (* Mapped from a file or device *) + MAP_ANON* = {1}; (* Allocated from anonymous virtual memory *) + MAP_COPY* = {5}; (* Virtual copy of region at mapping time *) + MAP_SHARED* = {4}; (* Share changes *) + MAP_PRIVATE* = {}; (* Changes private; copy pages on write *) + MAP_FIXED* = {8}; (* Map address must be exactly as requested *) + MAP_NOEXTEND* = {9} ; (* For MAP_FILE, don't change file size *) + MAP_HASSEMPHORE*= {10}; (* Region may contain semaphores *) + MAP_INHERIT* = {11} ; (* Region is retained after exec *) + MAP_FAILED* = -1; + + O_RDONLY* = {} ; (* Open read-only *) + O_WRONLY* = {0} ; (* Open write-only *) + O_RDWR* = {1} ; (* Open read/write *) + + SIG_BLOCK* = 0; (* Block signals *) + SIG_UNBLOCK* = 1; (* Unblock signals *) + SIG_SETMASK* = 2; (* Set the set of blocked signals *) + + _SC_PAGESIZE* = 30; + + SIGSTKSZ* = 8192; + + TYPE + __ftw_func_t* = PROCEDURE (fileName: PtrSTR; VAR [nil] stat: stat_t; flag: INTEGER): INTEGER; + PtrVoid* = INTEGER; + PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR; + wchar_t* = INTEGER; + PtrWSTR* = POINTER TO ARRAY [untagged] OF wchar_t; + PtrInt* = INTEGER; + StrArray* = POINTER TO ARRAY [untagged] OF PtrSTR; + PtrFILE* = INTEGER; + PtrDIR* = INTEGER; + PtrProc* = INTEGER; + clock_t* = INTEGER; + jmp_buf* = ARRAY [untagged] 6 OF INTEGER; (* bx, si, di, bp, sp, pc *) + mode_t* = SET; + off_t* = INTEGER; + SelectorFunc* = PROCEDURE (dirent: Dirent): INTEGER; + CmpFunc* = PROCEDURE (VAR [nil] dirent1, dirent2: PtrDirent): INTEGER; + size_t* = INTEGER; (* should be unsigned int *) + sigjmp_buf* = RECORD [untagged] + buf*: jmp_buf; + mask_was_saved*: INTEGER; + saved_mask*: sigset_t; + END; + + PtrDirent* = POINTER TO Dirent; + PtrDirentArray* = POINTER TO ARRAY [untagged] OF Dirent; + Dirent* = RECORD [untagged] + d_ino*: INTEGER; (* inode number *) + d_off*: off_t; (* offset to this dirent *) + d_reclen*: SHORTINT; (* length of this d_name *) + d_type*: BYTE; + d_name*: ARRAY[untagged] NAME_MAX+1 OF SHORTCHAR; (* file name (null-terminated) *) + END; + + pid_t* = INTEGER; + uid_t* = INTEGER; + sigval_t* = INTEGER; + + siginfo_t* = RECORD [untagged] + si_signo*: INTEGER; (* Signal number *) + si_errno*: INTEGER; (* An errno value *) + si_code*: INTEGER; (* Signal code *) + si_pid*: pid_t; (* Sending process ID *) + si_uid*: uid_t; (* Real user ID of sending process *) + si_status*: INTEGER; (* Exit value or signal *) + si_utime*: clock_t; (* User time consumed *) + si_stime*: clock_t; (* System time consumed *) + si_value*: sigval_t; (* Signal value *) + si_int*: INTEGER; (* POSIX.1b signal *) + si_ptr*: PtrVoid; (* POSIX.1b signal *) + si_addr*: PtrVoid; (* Memory location which caused fault *) + si_band*: INTEGER; (* Band event *) + si_fd*: INTEGER; (* File descriptor *) + END; + Ptrsiginfo_t* = POINTER TO siginfo_t; + + sigset_t* = ARRAY [untagged] 128 OF BYTE; + Ptrsigset_t* = INTEGER; + sigaction_t* = RECORD [untagged] + sa_sigaction*: PROCEDURE [ccall] (sig: INTEGER; siginfo: Ptrsiginfo_t; ptr: Ptrucontext_t); (* union with sa_handler*: PtrProc;*) + sa_mask*: sigset_t; + sa_flags*: SET; + sa_restorer*: LONGINT; + END; + + stack_t* = RECORD [untagged] + ss_sp*: PtrVoid; + ss_flags*: INTEGER; + ss_size*: size_t; + END; + + stat_t* = RECORD [untagged] + st_dev*: LONGINT; (* device *) + __pad1: SHORTINT; + st_ino*: INTEGER; (* 64? inode *) + st_mode*: mode_t; (* protection *) + st_nlink*: INTEGER; (* number of hard links *) + st_uid*: uid_t; (* user ID of owner *) + st_gid*: INTEGER; (* group ID of owner *) + st_rdev*: LONGINT; (* device type (if inode device) *) + __pad2: SHORTINT; + st_size*: off_t; (* 64? total size, in bytes *) + st_blksize*: INTEGER; (* blocksize for filesystem I/O *) + st_blocks*: INTEGER; (* 64? number of blocks allocated *) + st_atime*: INTEGER; (* time of last access *) + __unused1: INTEGER; + st_mtime*: INTEGER; (* time of last modification *) + __unused2: INTEGER; + st_ctime*: INTEGER; (* time of last change *) + __unused3: INTEGER; + __unused4: INTEGER; + __unused5: INTEGER; + END; + + fpreg* = RECORD [untagged] + significand*: ARRAY [untagged] 4 OF CHAR; + exponent*: CHAR; + END; + + fpstate* = RECORD [untagged] + cw*: INTEGER; (* unsigned long int *) + sw*: INTEGER; (* unsigned long int *) + tag*: INTEGER; (* unsigned long int *) + ipoff*: INTEGER; (* unsigned long int *) + cssel*: INTEGER; (* unsigned long int *) + dataoff*: INTEGER; (* unsigned long int *) + datasel*: INTEGER; (* unsigned long int *) + _st: ARRAY [untagged] 8 OF fpreg; + status*: INTEGER; (* unsigned long int *) + END; + + gregset_t* = ARRAY [untagged] 19 OF INTEGER; + fpregset_t* = POINTER TO fpstate; + + mcontext_t* = RECORD [untagged] + gregs*: gregset_t; + fpregs*: fpregset_t; + oldmask*: INTEGER; (* unsigned long int *) + cr2*: INTEGER; (* unsigned long int *) + END; + + Ptrucontext_t* = POINTER TO ucontext_t; + ucontext_t* = RECORD [untagged] + uc_flags*: INTEGER; (* unsigned long int *) + uc_link*: Ptrucontext_t; + uc_stack*: stack_t; + uc_mcontext*: mcontext_t; + uc_sigmask: sigset_t; + __fpregs_mem*: fpstate; + END; + + (* Times and Dates *) + + tm* = POINTER TO tmDesc; + tmDesc* = RECORD [untagged] + tm_sec*: INTEGER; (* seconds *) + tm_min*: INTEGER; (* minutes *) + tm_hour*: INTEGER; (* hours *) + tm_mday*: INTEGER; (* day of the month *) + tm_mon*: INTEGER; (* month *) + tm_year*: INTEGER; (* year *) + tm_wday*: INTEGER; (* day of the week *) + tm_yday*: INTEGER; (* day in the year *) + tm_isdst*: INTEGER; (* daylight saving time *) + END; + time_t* = INTEGER; + + VAR + timezone*: INTEGER; (* seconds from GMT *) + stdin*, stdout*, stderr* : PtrFILE; + + PROCEDURE [ccall] calloc* (num, size: size_t): PtrVoid; + PROCEDURE [ccall] clock* (): clock_t; + PROCEDURE [ccall] closedir* (dir: PtrDIR): INTEGER; + PROCEDURE [ccall] chmod* (path: PtrSTR; mode: mode_t); + PROCEDURE [ccall] exit* (status: INTEGER); + PROCEDURE [ccall] fclose* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fflush* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fopen* (filename, mode: PtrSTR): PtrFILE; + PROCEDURE [ccall] feof* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fread* (ptr: PtrVoid; size, nobj: size_t; stream: PtrFILE): size_t; + PROCEDURE [ccall] fseek* (stream: PtrFILE; offset, origin: INTEGER): INTEGER; + PROCEDURE [ccall] free* (p: PtrVoid); + PROCEDURE [ccall] ftell* (stream: PtrFILE): LONGINT; + PROCEDURE [ccall] ftw* (filename: PtrSTR; func: __ftw_func_t; descriptors: INTEGER): INTEGER; + PROCEDURE [ccall] fwrite* (ptr: PtrVoid; size, nobj: size_t; stream: PtrFILE): size_t; + PROCEDURE [ccall] getcwd* (buf: PtrSTR; size: size_t): PtrSTR; + PROCEDURE [ccall] getcontext* (ucontext_t: Ptrucontext_t): INTEGER; + PROCEDURE [ccall] gets* (s: PtrSTR); + PROCEDURE [ccall] fgets* (s: PtrSTR; n: INTEGER; fp: PtrFILE): PtrSTR; + PROCEDURE [ccall] gmtime* (VAR timep: time_t): tm; + PROCEDURE [ccall] kill* (pid: pid_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] localtime* (VAR timep: time_t): tm; + PROCEDURE [ccall] malloc* (size: size_t): PtrVoid; + PROCEDURE [ccall] mkdir* (pathname: PtrSTR; mode: mode_t): INTEGER; + PROCEDURE [ccall] mktime* (timeptr: tm): time_t; + PROCEDURE [ccall] opendir* (name: PtrSTR): PtrDIR; + PROCEDURE [ccall] printf* (s: PtrSTR): INTEGER; + PROCEDURE [ccall] readdir* (dir: PtrDIR): PtrDirent; + PROCEDURE [ccall] remove* (filename: PtrSTR): INTEGER; + PROCEDURE [ccall] rename* (oldname, newname: PtrSTR): INTEGER; + PROCEDURE [ccall] scandir* (dir: PtrDIR; namelist: PtrDirentArray; selector: SelectorFunc; cmp: CmpFunc): INTEGER; + PROCEDURE [ccall] setcontext* (ucontext_t: Ptrucontext_t): INTEGER; + PROCEDURE [ccall] setjmp* (VAR env: jmp_buf): INTEGER; + PROCEDURE [ccall] sigaction* (sig_num: INTEGER; VAR [nil] act: sigaction_t; VAR [nil] oldact: sigaction_t): INTEGER; + PROCEDURE [ccall] sigaddset* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] sigdelset* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] sigemptyset* (set: Ptrsigset_t): INTEGER; + PROCEDURE [ccall] sigfillset* (set: Ptrsigset_t): INTEGER; + PROCEDURE [ccall] sigismemeber* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] siglongjmp* (VAR env: sigjmp_buf; val: INTEGER); + PROCEDURE [ccall] signal* (sig_num: INTEGER; sighandler: PtrProc): PtrProc; + PROCEDURE [ccall] sigsetjmp* ["__sigsetjmp"] (VAR env: sigjmp_buf; savemask: INTEGER): INTEGER; +(* + PROCEDURE [ccall] stat* (filename: PtrSTR; VAR buf: stat_t): INTEGER; stat is a macro and expands to __xstat(3, filename, buf) +*) + PROCEDURE [ccall] __xstat* (version: INTEGER; filename: PtrSTR; VAR buf: stat_t): INTEGER; + PROCEDURE [ccall] strftime* (s: PtrSTR; max: size_t; format: PtrSTR; ptm: tm): size_t; + PROCEDURE [ccall] time* (VAR [nil] t: time_t): time_t; + + PROCEDURE [ccall] __errno_location*(): INTEGER; + + PROCEDURE [ccall] open* (name: PtrSTR; flags: SET; mode: mode_t): INTEGER; + PROCEDURE [ccall] close* (d: INTEGER): INTEGER; + PROCEDURE [ccall] read* (d: INTEGER; buf: PtrVoid; nbytes: size_t): INTEGER; + PROCEDURE [ccall] write* (d: INTEGER; buf: PtrVoid; nBytes: size_t): INTEGER; + + PROCEDURE [ccall] mmap* (addr: PtrVoid; len: size_t; prot: SET; flags: SET; fd, offset: off_t): PtrVoid; + PROCEDURE [ccall] munmap* (addr: PtrVoid; len: size_t): INTEGER; + PROCEDURE [ccall] mprotect* (addr: PtrVoid; len: size_t; prot: SET): INTEGER; + + PROCEDURE [ccall] getenv* (name: PtrSTR): PtrSTR; + + PROCEDURE [ccall] sysconf* (name: INTEGER): INTEGER; + + PROCEDURE [ccall] sigaltstack* (VAR [nil] ss: stack_t; VAR [nil] oss: stack_t): INTEGER; + + PROCEDURE [ccall] sigprocmask* (how: INTEGER; set: Ptrsigset_t; oldset: Ptrsigset_t): INTEGER; + +END LinLibc. \ No newline at end of file diff --git a/Trurl-based/_Linux_/Lin/Rsrc/loader/BlackBox b/Trurl-based/_Linux_/Lin/Rsrc/loader/BlackBox new file mode 100755 index 0000000..c456d0e Binary files /dev/null and b/Trurl-based/_Linux_/Lin/Rsrc/loader/BlackBox differ diff --git a/Trurl-based/_Linux_/Lin/Rsrc/loader/Makefile b/Trurl-based/_Linux_/Lin/Rsrc/loader/Makefile new file mode 100644 index 0000000..16b78c9 --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Rsrc/loader/Makefile @@ -0,0 +1,21 @@ +# This is GNU Makefile +# BSD GNU +# ${.TARGET} $@ +# ${.ALLSRC} $^ +# ${.IMPSRC} $< + +all: dev0 BlackBox + +CFLAGS += -Wall -O0 -g -m32 + +#BlackBox: BlackBox.c +# ${CC} ${CFLAGS} -o $@ $^ -L. -lBB + +BlackBox: BlackBox-dl.c + ${CC} ${CFLAGS} -o $@ $^ -ldl + +dev0: dev0.c + ${CC} ${CFLAGS} -o $@ $^ -ldl + +clean: + rm -f dev0 BlackBox diff --git a/Trurl-based/_Linux_/Lin/Rsrc/loader/dev0 b/Trurl-based/_Linux_/Lin/Rsrc/loader/dev0 new file mode 100755 index 0000000..2ea46b7 Binary files /dev/null and b/Trurl-based/_Linux_/Lin/Rsrc/loader/dev0 differ diff --git a/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB.so b/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB.so new file mode 120000 index 0000000..85c28c4 --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB.so @@ -0,0 +1 @@ +../../../libBB.so \ No newline at end of file diff --git a/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB0.so b/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB0.so new file mode 120000 index 0000000..6319f6b --- /dev/null +++ b/Trurl-based/_Linux_/Lin/Rsrc/loader/libBB0.so @@ -0,0 +1 @@ +../../../libBB0.so \ No newline at end of file diff --git a/Trurl-based/_Linux_/System/Mod/Kernel.odc b/Trurl-based/_Linux_/System/Mod/Kernel.odc new file mode 100644 index 0000000..505a0d5 Binary files /dev/null and b/Trurl-based/_Linux_/System/Mod/Kernel.odc differ diff --git a/Trurl-based/_Linux_/System/Mod/Kernel.txt b/Trurl-based/_Linux_/System/Mod/Kernel.txt new file mode 100644 index 0000000..f4cb949 --- /dev/null +++ b/Trurl-based/_Linux_/System/Mod/Kernel.txt @@ -0,0 +1,2074 @@ +MODULE Kernel; + + (* THIS IS TEXT COPY OF Kernel.odc *) + (* DO NOT EDIT *) + + (* A. V. Shiryaev, 2012.11 + Linux Kernel + Based on 1.6-rc6 Windows Kernel + + 20120822 Marc changes + Some parts taken from OpenBUGS linKernel + + Most Windows-specific code removed + Some Windows-specific code commented and marked red + Windows COM-specific code re-marked from green to gray + Linux(/OpenBSD)-specific code marked green + + TODO: + handle stack overflow exceptions + Quit from TrapHandler + *) + + IMPORT S := SYSTEM, Libc := LinLibc, Dl := LinDl; + + CONST + strictStackSweep = TRUE; + + nameLen* = 256; + + littleEndian* = TRUE; + timeResolution* = 1000; (* ticks per second *) + + processor* = 10; (* i386 *) + + objType* = "ocf"; (* file types *) + symType* = "osf"; + docType* = "odc"; + + (* loader constants *) + done* = 0; + fileNotFound* = 1; + syntaxError* = 2; + objNotFound* = 3; + illegalFPrint* = 4; + cyclicImport* = 5; + noMem* = 6; + commNotFound* = 7; + commSyntaxError* = 8; + moduleNotFound* = 9; + + any = 1000000; + + CX = 1; + SP = 4; (* register number of stack pointer *) + FP = 5; (* register number of frame pointer *) + ML = 3; (* register which holds the module list at program start *) + + N = 128 DIV 16; (* free lists *) + + (* kernel flags in module desc *) + init = 16; dyn = 17; dll = 24; iptrs = 30; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + + debug = FALSE; + + +(* + sigStackSize = MAX(Libc.SIGSTKSZ, 65536); +*) + + trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *) + + (* constants for the message boxes *) + mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5; + + TYPE + Name* = ARRAY nameLen OF SHORTCHAR; + Command* = PROCEDURE; + + Module* = POINTER TO RECORD [untagged] + next-: Module; + opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *) + refcnt-: INTEGER; (* <0: module invalidated *) + compTime-, loadTime-: ARRAY 6 OF SHORTINT; + ext-: INTEGER; (* currently not used *) + term-: Command; (* terminator *) + nofimps-, nofptrs-: INTEGER; + csize-, dsize-, rsize-: INTEGER; + code-, data-, refs-: INTEGER; + procBase-, varBase-: INTEGER; (* meta base addresses *) + names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *) + ptrs-: POINTER TO ARRAY [untagged] OF INTEGER; + imports-: POINTER TO ARRAY [untagged] OF Module; + export-: Directory; (* exported objects (name sorted) *) + name-: Name + END; + + Type* = POINTER TO RECORD [untagged] + (* record: ptr to method n at offset - 4 * (n+1) *) + size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *) + mod-: Module; + id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *) + base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *) + fields-: Directory; (* new fields (declaration order) *) + ptroffs-: ARRAY any OF INTEGER (* array of any length *) + END; + + Object* = POINTER TO ObjDesc; + + ObjDesc* = RECORD [untagged] + fprint-: INTEGER; + offs-: INTEGER; (* pvfprint for record types *) + id-: INTEGER; (* name idx * 256 + vis * 16 + mode *) + struct-: Type (* id of basic type or pointer to typedesc/signature *) + END; + + Directory* = POINTER TO RECORD [untagged] + num-: INTEGER; (* number of entries *) + obj-: ARRAY any OF ObjDesc (* array of any length *) + END; + + Signature* = POINTER TO RECORD [untagged] + retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *) + num-: INTEGER; (* number of parameters *) + par-: ARRAY any OF RECORD [untagged] (* parameters *) + id-: INTEGER; (* name idx * 256 + kind *) + struct-: Type (* id of basic type or pointer to typedesc *) + END + END; + + Handler* = PROCEDURE; + + Reducer* = POINTER TO ABSTRACT RECORD + next: Reducer + END; + + Identifier* = ABSTRACT RECORD + typ*: INTEGER; + obj-: ANYPTR + END; + + TrapCleaner* = POINTER TO ABSTRACT RECORD + next: TrapCleaner + END; + + TryHandler* = PROCEDURE (a, b, c: INTEGER); + + + (* meta extension suport *) + + ItemExt* = POINTER TO ABSTRACT RECORD END; + + ItemAttr* = RECORD + obj*, vis*, typ*, adr*: INTEGER; + mod*: Module; + desc*: Type; + ptr*: S.PTR; + ext*: ItemExt + END; + + Hook* = POINTER TO ABSTRACT RECORD END; + + LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) + res*: INTEGER; + importing*, imported*, object*: ARRAY 256 OF CHAR + END; + + GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *) + + Block = POINTER TO RECORD [untagged] + tag: Type; + last: INTEGER; (* arrays: last element *) + actual: INTEGER; (* arrays: used during mark phase *) + first: INTEGER (* arrays: first element *) + END; + + FreeBlock = POINTER TO FreeDesc; + + FreeDesc = RECORD [untagged] + tag: Type; (* f.tag = ADR(f.size) *) + size: INTEGER; + next: FreeBlock + END; + + Cluster = POINTER TO RECORD [untagged] + size: INTEGER; (* total size *) + next: Cluster; + max: INTEGER + (* start of first block *) + END; + + FList = POINTER TO RECORD + next: FList; + blk: Block; + iptr, aiptr: BOOLEAN + END; + + CList = POINTER TO RECORD + next: CList; + do: Command; + trapped: BOOLEAN + END; + + + PtrType = RECORD v: S.PTR END; (* used for array of pointer *) + Char8Type = RECORD v: SHORTCHAR END; + Char16Type = RECORD v: CHAR END; + Int8Type = RECORD v: BYTE END; + Int16Type = RECORD v: SHORTINT END; + Int32Type = RECORD v: INTEGER END; + Int64Type = RECORD v: LONGINT END; + BoolType = RECORD v: BOOLEAN END; + SetType = RECORD v: SET END; + Real32Type = RECORD v: SHORTREAL END; + Real64Type = RECORD v: REAL END; + ProcType = RECORD v: PROCEDURE END; + UPtrType = RECORD v: INTEGER END; + StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + (* Linux specific boot loader info. Record must be identical to struct in the loader. *) + BootInfo* = POINTER TO RECORD [untagged] + modList: Module; + argc-: INTEGER; + argv-: Libc.StrArray + END; + + VAR + baseStack: INTEGER; (* modList, root, and baseStack must be together for remote debugging *) + root: Cluster; (* cluster list *) + modList-: Module; (* root of module list *) + trapCount-: INTEGER; + err-, pc-, sp-, fp-, stack-, val-: INTEGER; + + free: ARRAY N OF FreeBlock; (* free list *) + sentinelBlock: FreeDesc; + sentinel: FreeBlock; + candidates: ARRAY 1024 OF INTEGER; + nofcand: INTEGER; + allocated: INTEGER; (* bytes allocated on BlackBox heap *) + total: INTEGER; (* current total size of BlackBox heap *) + used: INTEGER; (* bytes allocated on system heap *) + finalizers: FList; + hotFinalizers: FList; + cleaners: CList; + reducers: Reducer; + trapStack: TrapCleaner; + actual: Module; (* valid during module initialization *) + + res: INTEGER; (* auxiliary global variables used for trap handling *) + old: INTEGER; + + trapViewer, trapChecker: Handler; + trapped, guarded, secondTrap: BOOLEAN; + interrupted: BOOLEAN; + static, inDll, terminating: BOOLEAN; + restart: Command; + + told, shift: INTEGER; (* used in Time() *) + + loader: LoaderHook; + loadres: INTEGER; + + wouldFinalize: BOOLEAN; + + watcher*: PROCEDURE (event: INTEGER); (* for debugging *) + + +(* + sigStack: Libc.PtrVoid; +*) + + zerofd: INTEGER; + pageSize: INTEGER; + + loopContext: Libc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *) + currentTryContext: POINTER TO Libc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *) + isReadableContext: Libc.sigjmp_buf; (* for IsReadable *) + isReadableCheck: BOOLEAN; + + guiHook: GuiHook; + + (* !!! This variable has to be the last variable in the list. !!! *) + bootInfo-: BootInfo; + + (* code procedures for fpu *) + + PROCEDURE [1] FINIT 0DBH, 0E3H; + PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH; (* -4, FP *) + PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH; (* -4, FP *) + + (* code procedure for memory erase *) + + PROCEDURE [code] Erase (adr, words: INTEGER) + 089H, 0C7H, (* MOV EDI, EAX *) + 031H, 0C0H, (* XOR EAX, EAX *) + 059H, (* POP ECX *) + 0F2H, 0ABH; (* REP STOS *) + + (* code procedure for stack allocate *) + + PROCEDURE [code] ALLOC (* argument in CX *) + (* + PUSH EAX + ADD ECX,-5 + JNS L0 + XOR ECX,ECX + L0: AND ECX,-4 (n-8+3)/4*4 + MOV EAX,ECX + AND EAX,4095 + SUB ESP,EAX + MOV EAX,ECX + SHR EAX,12 + JEQ L2 + L1: PUSH 0 + SUB ESP,4092 + DEC EAX + JNE L1 + L2: ADD ECX,8 + MOV EAX,[ESP,ECX,-4] + PUSH EAX + MOV EAX,[ESP,ECX,-4] + SHR ECX,2 + RET + *); + + PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; + + + (* meta extension suport *) + + PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + + + (* -------------------- miscellaneous tools -------------------- *) + + PROCEDURE Msg (IN str: ARRAY OF CHAR); + VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER; + BEGIN + ss := SHORT(str); + l := LEN(ss$); + ss[l] := 0AX; ss[l + 1] := 0X; + res := Libc.printf(ss) + END Msg; + + PROCEDURE Int (x: LONGINT); + VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR; + BEGIN + IF x # MIN(LONGINT) THEN + IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 + ELSE + a := "8085774586302733229"; s[0] := "-"; k := 1; + j := 0; WHILE a[j] # 0X DO INC(j) END + END; + ASSERT(k + j < LEN(s), 20); + REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X; + Msg(s); + END Int; + + PROCEDURE (h: GuiHook) MessageBox* ( + title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT; + PROCEDURE (h: GuiHook) Beep*, NEW, ABSTRACT; + + (* Is extended by HostGnome to show dialogs. If no dialog is present or + if the dialog is not closed by using one button, then "mbClose" is returned *) + PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER; + VAR res: INTEGER; + BEGIN + IF guiHook # NIL THEN + res := guiHook.MessageBox(title, msg, buttons) + ELSE + Msg(" "); + Msg("****"); + Msg("* " + title); + Msg("* " + msg); + Msg("****"); + res := mbClose; + END; + RETURN res + END MessageBox; + + PROCEDURE SetGuiHook* (hook: GuiHook); + BEGIN + guiHook := hook + END SetGuiHook; + + PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); + (* portable *) + VAR i, j: INTEGER; ch, lch: CHAR; + BEGIN + i := 0; ch := name[0]; + IF ch # 0X THEN + REPEAT + head[i] := ch; lch := ch; INC(i); ch := name[i] + UNTIL (ch = 0X) + OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ")) + & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ")); + head[i] := 0X; j := 0; + WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; + tail[j] := 0X; + IF tail = "" THEN tail := head$; head := "" END + ELSE head := ""; tail := "" + END + END SplitName; + + PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; + BEGIN + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSIF i < LEN(name) - 4 THEN + IF type = "" THEN ext := docType ELSE ext := type$ END; + name[i] := "."; INC(i); j := 0; ch := ext[0]; + WHILE ch # 0X DO + IF (ch >= "A") & (ch <= "Z") THEN + ch := CHR(ORD(ch) + ORD("a") - ORD("A")) + END; + name[i] := ch; INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END MakeFileName; + + PROCEDURE Time* (): LONGINT; + VAR t: INTEGER; + BEGIN + (* t := WinApi.GetTickCount(); *) + + (* Linux *) + t := Libc.clock() DIV (Libc.CLOCKS_PER_SECOND DIV 1000); (* processor time to milliseconds *) + + IF t < told THEN INC(shift) END; + told := t; + RETURN shift * 100000000L + t + END Time; + + PROCEDURE Beep* (); + VAR ss: ARRAY 2 OF SHORTCHAR; + BEGIN + IF guiHook # NIL THEN + guiHook.Beep + ELSE + ss[0] := 007X; ss[1] := 0X; + res := Libc.printf(ss); res := Libc.fflush(Libc.NULL) + END + END Beep; + + PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); + BEGIN + adr := var; m := NIL; + IF var # 0 THEN + m := modList; + WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; + IF m # NIL THEN DEC(adr, m.code) END + END + END SearchProcVar; + + + (* -------------------- system memory management --------------------- *) + + (* A. V. Shiryaev, 2012.10: NOTE: it seems that GC works correctly with positive addesses only *) + +(* + PROCEDURE HeapAlloc (adr: INTEGER; size: INTEGER; prot: SET): Libc.PtrVoid; + VAR + x: Libc.PtrVoid; + res: INTEGER; + BEGIN + x := Libc.calloc(1, size); (* calloc initialize allocated space to zero *) + IF x # Libc.NULL THEN + res := Libc.mprotect(x, size, prot); + IF res # 0 THEN + Libc.free(x); + x := Libc.NULL; + Msg("Kernel.HeapAlloc: mprotect failed!"); + HALT(100) + END + END; + RETURN x + END HeapAlloc; +*) + PROCEDURE HeapAlloc (adr: Libc.PtrVoid; size: INTEGER; prot: SET): Libc.PtrVoid; + VAR x: Libc.PtrVoid; + BEGIN + x := Libc.mmap(adr, size, prot, Libc.MAP_PRIVATE + Libc.MAP_ANON, zerofd, 0); + IF x = Libc.MAP_FAILED THEN + x := Libc.NULL + ELSE + ASSERT(size MOD 4 = 0, 100); + Erase(x, size DIV 4) + END; + RETURN x + END HeapAlloc; + +(* + PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); + VAR res: INTEGER; + BEGIN +(* + ASSERT(size MOD 4 = 0, 100); + Erase(adr, size DIV 4); + res := Libc.mprotect(adr, size, Libc.PROT_NONE); + ASSERT(res = 0, 101); +*) + Libc.free(adr) + END HeapFree; +*) + PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); + VAR res: INTEGER; + BEGIN +(* + ASSERT(size MOD 4 = 0, 100); + Erase(adr, size DIV 4); + res := Libc.mprotect(adr, size, Libc.PROT_NONE); + ASSERT(res = 0, 101); +*) + res := Libc.munmap(adr, size); + ASSERT(res = 0, 102) + END HeapFree; + + PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); + (* allocate at least size bytes, typically at least 256 kbytes are allocated *) + CONST N = 65536; (* cluster size for dll *) + prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); + VAR adr: INTEGER; + allocated: INTEGER; + BEGIN + INC(size, 16); + ASSERT(size > 0, 100); adr := 0; + IF size < N THEN adr := HeapAlloc(1, N, prot) END; + IF adr = 0 THEN adr := HeapAlloc(1, size, prot); allocated := size ELSE allocated := N END; + IF adr = 0 THEN c := NIL + ELSE + c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr; + c.size := allocated - (S.VAL(INTEGER, c) - adr); + INC(used, c.size); INC(total, c.size) + END + (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) + END AllocHeapMem; + + PROCEDURE FreeHeapMem (c: Cluster); + BEGIN + DEC(used, c.size); DEC(total, c.size); + HeapFree(c.max, (S.VAL(INTEGER, c) - c.max) + c.size) + END FreeHeapMem; + + PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); + CONST + prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); + BEGIN + descAdr := HeapAlloc(0, descSize, prot); + IF descAdr # 0 THEN + modAdr := HeapAlloc(0, modSize, prot); + IF modAdr # 0 THEN INC(used, descSize + modSize) + ELSE HeapFree(descAdr, descSize); descAdr := 0 + END + ELSE modAdr := 0 + END + END AllocModMem; + + PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); + BEGIN + DEC(used, descSize + modSize); + HeapFree(descAdr, descSize); + HeapFree(modAdr, modSize) + END DeallocModMem; + + PROCEDURE InvalModMem (modSize, modAdr: INTEGER); + BEGIN + DEC(used, modSize); + HeapFree(modAdr, modSize) + END InvalModMem; + +(* + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + (* check wether memory between from (incl.) and to (excl.) may be read *) + BEGIN + RETURN WinApi.IsBadReadPtr(from, to - from) = 0 + END IsReadable; +*) + + (* Alexander Shiryaev, 2012.10: Linux: can be implemented through mincore/madvise *) + (* This procedure can be called from TrapHandler also *) + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + (* check wether memory between from (incl.) and to (excl.) may be read *) + VAR res: BOOLEAN; res1: INTEGER; + x: SHORTCHAR; + mask, omask: Libc.sigset_t; + BEGIN + (* save old sigmask and unblock SIGSEGV *) + res1 := Libc.sigemptyset(S.ADR(mask)); + ASSERT(res1 = 0, 100); + res1 := Libc.sigaddset(S.ADR(mask), Libc.SIGSEGV); + ASSERT(res1 = 0, 101); + res1 := Libc.sigprocmask(Libc.SIG_UNBLOCK, S.ADR(mask), S.ADR(omask)); + ASSERT(res1 = 0, 102); + + res := FALSE; + res1 := Libc.sigsetjmp(isReadableContext, Libc.TRUE); + IF res1 = 0 THEN + isReadableCheck := TRUE; + (* read memory *) + REPEAT + S.GET(from, x); + INC(from) + UNTIL from = to; + res := TRUE + ELSE + ASSERT(res1 = 1, 103) + END; + isReadableCheck := FALSE; + + (* restore saved sigmask *) + res1 := Libc.sigprocmask(Libc.SIG_SETMASK, S.ADR(omask), Libc.NULL); + ASSERT(res1 = 0, 104); + + RETURN res + END IsReadable; + + (* --------------------- NEW implementation (portable) -------------------- *) + + PROCEDURE^ NewBlock (size: INTEGER): Block; + + PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) + VAR size: INTEGER; b: Block; tag: Type; l: FList; + BEGIN + IF ODD(typ) THEN (* record contains interface pointers *) + tag := S.VAL(Type, typ - 1); + b := NewBlock(tag.size); + IF b = NIL THEN RETURN 0 END; + b.tag := tag; + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.iptr := TRUE; l.next := finalizers; finalizers := l; + RETURN S.ADR(b.last) + ELSE + tag := S.VAL(Type, typ); + b := NewBlock(tag.size); + IF b = NIL THEN RETURN 0 END; + b.tag := tag; S.GET(typ - 4, size); + IF size # 0 THEN (* record uses a finalizer *) + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.next := finalizers; finalizers := l + END; + RETURN S.ADR(b.last) + END + END NewRec; + + PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) + VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList; + BEGIN + IF (nofdim < 0)OR(nofdim>1FFFFFFCH) THEN RETURN 0 END;(*20120822 Marc*) + headSize := 4 * nofdim + 12; fin := FALSE; + CASE eltyp OF +(* + | -1: eltyp := S.ADR(IntPtrType); fin := TRUE +*) + | -1: HALT(100) + | 0: eltyp := S.ADR(PtrType) + | 1: eltyp := S.ADR(Char8Type) + | 2: eltyp := S.ADR(Int16Type) + | 3: eltyp := S.ADR(Int8Type) + | 4: eltyp := S.ADR(Int32Type) + | 5: eltyp := S.ADR(BoolType) + | 6: eltyp := S.ADR(SetType) + | 7: eltyp := S.ADR(Real32Type) + | 8: eltyp := S.ADR(Real64Type) + | 9: eltyp := S.ADR(Char16Type) + | 10: eltyp := S.ADR(Int64Type) + | 11: eltyp := S.ADR(ProcType) + | 12: eltyp := S.ADR(UPtrType) + ELSE (* eltyp is desc *) + IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END + END; + t := S.VAL(Type, eltyp); + ASSERT(t .size> 0,100); + IF (nofelem < 0) OR( (7FFFFFFFH-headSize) DIV t.size < nofelem) THEN (* 20120822 Marc*) + RETURN 0 + END; + size := headSize + nofelem * t.size; + b := NewBlock(size); + IF b = NIL THEN RETURN 0 END; + b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) + b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) + b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) + IF fin THEN + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.aiptr := TRUE; l.next := finalizers; finalizers := l + END; + RETURN S.ADR(b.last) + END NewArr; + + + (* -------------------- handler installation (portable) --------------------- *) + + PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; + VAR l: FList; + BEGIN + ASSERT(id.typ # 0, 100); + l := finalizers; + WHILE l # NIL DO + IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN + id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); + IF id.Identified() THEN RETURN id.obj END + END; + l := l.next + END; + RETURN NIL + END ThisFinObj; + + PROCEDURE InstallReducer* (r: Reducer); + BEGIN + r.next := reducers; reducers := r + END InstallReducer; + + PROCEDURE InstallTrapViewer* (h: Handler); + BEGIN + trapViewer := h + END InstallTrapViewer; + + PROCEDURE InstallTrapChecker* (h: Handler); + BEGIN + trapChecker := h + END InstallTrapChecker; + + PROCEDURE PushTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; + ASSERT(t = NIL, 20); + c.next := trapStack; trapStack := c + END PushTrapCleaner; + + PROCEDURE PopTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := NIL; + WHILE (trapStack # NIL) & (t # c) DO + t := trapStack; trapStack := trapStack.next + END + END PopTrapCleaner; + + PROCEDURE InstallCleaner* (p: Command); + VAR c: CList; + BEGIN + c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) + c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c + END InstallCleaner; + + PROCEDURE RemoveCleaner* (p: Command); + VAR c0, c: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; + IF c # NIL THEN + IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END + END + END RemoveCleaner; + + PROCEDURE Cleanup*; + VAR c, c0: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE c # NIL DO + IF ~c.trapped THEN + c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c + ELSE + IF c0 = NIL THEN cleaners := cleaners.next + ELSE c0.next := c.next + END + END; + c := c.next + END + END Cleanup; + + (* -------------------- meta information (portable) --------------------- *) + + PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF SHORTCHAR): Module, NEW, ABSTRACT; + + PROCEDURE SetLoaderHook*(h: LoaderHook); + BEGIN + loader := h + END SetLoaderHook; + + PROCEDURE InitModule (mod: Module); (* initialize linked modules *) + VAR body: Command; + res: INTEGER; errno: INTEGER; + BEGIN + IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; + IF ~(init IN mod.opts) THEN + body := S.VAL(Command, mod.code); + INCL(mod.opts, init); + actual := mod; + + (* A. V. Shiryaev: Allow execution on code pages *) + (* Linux: must be page-aligned *) + res := Libc.mprotect( + (mod.code DIV pageSize) * pageSize, + ((mod.csize + mod.code MOD pageSize - 1) DIV pageSize) * pageSize + pageSize, + Libc.PROT_READ + Libc.PROT_WRITE + Libc.PROT_EXEC); + IF res = -1 THEN + S.GET( Libc.__errno_location(), errno ); + Msg("ERROR: Kernel.InitModule: mprotect failed!"); + Msg(mod.name$); Int(mod.code); Int(mod.csize); Int(errno); + HALT(100) + ELSE ASSERT(res = 0) + END; + + body(); actual := NIL + END + END InitModule; + + PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module; (* loaded modules only *) + VAR m: Module; + BEGIN + loadres := done; + m := modList; + WHILE (m # NIL) & ((m.name # name) OR (m.refcnt < 0)) DO m := m.next END; + IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; + IF m = NIL THEN loadres := moduleNotFound END; + RETURN m + END ThisLoadedMod; + + PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; + VAR n : Name; + BEGIN + n := SHORT(name$); + IF loader # NIL THEN + loader.res := done; + RETURN loader.ThisMod(n) + ELSE + RETURN ThisLoadedMod(n) + END + END ThisMod; + + PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); + VAR m: Module; + BEGIN + m := ThisMod(name) + END LoadMod; + + PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); + BEGIN + IF loader # NIL THEN + res := loader.res; + importing := loader.importing$; + imported := loader.imported$; + object := loader.object$ + ELSE + res := loadres; + importing := ""; + imported := ""; + object := "" + END + END GetLoaderResult; + + PROCEDURE ThisObject* (mod: Module; name: ARRAY OF SHORTCHAR): Object; + VAR l, r, m: INTEGER; p: StrPtr; + BEGIN + l := 0; r := mod.export.num; + WHILE l < r DO (* binary search *) + m := (l + r) DIV 2; + p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); + IF p^ = name THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; + IF p^ < name THEN l := m + 1 ELSE r := m END + END; + RETURN NIL + END ThisObject; + + PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; + VAR i, n: INTEGER; + BEGIN + i := 0; n := mod.export.num; + WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO + IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; + INC(i) + END; + RETURN NIL + END ThisDesc; + + PROCEDURE ThisField* (rec: Type; name: ARRAY OF SHORTCHAR): Object; + VAR n: INTEGER; p: StrPtr; obj: Object; m: Module; + BEGIN + m := rec.mod; + obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; + WHILE n > 0 DO + p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); + IF p^ = name THEN RETURN obj END; + DEC(n); INC(S.VAL(INTEGER, obj), 16) + END; + RETURN NIL + END ThisField; + + PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command; + VAR x: Object; sig: Signature; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mProc) THEN + sig := S.VAL(Signature, x.struct); + IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END + END; + RETURN NIL + END ThisCommand; + + PROCEDURE ThisType* (mod: Module; name: ARRAY OF SHORTCHAR): Type; + VAR x: Object; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN + RETURN x.struct + ELSE + RETURN NIL + END + END ThisType; + + PROCEDURE TypeOf* (IN rec: ANYREC): Type; + BEGIN + RETURN S.VAL(Type, S.TYP(rec)) + END TypeOf; + + PROCEDURE LevelOf* (t: Type): SHORTINT; + BEGIN + RETURN SHORT(t.id DIV 16 MOD 16) + END LevelOf; + + PROCEDURE NewObj* (VAR o: S.PTR; t: Type); + VAR i: INTEGER; + BEGIN + IF t.size = -1 THEN o := NIL + ELSE + i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; + IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) + o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) + END + END NewObj; + + PROCEDURE GetObjName* (mod: Module; obj: Object; VAR name: Name); + VAR p: StrPtr; + BEGIN + p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); + name := p^$ + END GetObjName; + + PROCEDURE GetTypeName* (t: Type; VAR name: Name); + VAR p: StrPtr; + BEGIN + p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); + name := p^$ + END GetTypeName; + + PROCEDURE RegisterMod* (mod: Module); + VAR i: INTEGER; + t: Libc.time_t; tm: Libc.tm; + BEGIN + mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; + WHILE i < mod.nofimps DO + IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; + INC(i) + END; + + t := Libc.time(NIL); + tm := Libc.localtime(t); + mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *) + mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *); + mod.loadTime[2] := SHORT(tm.tm_mday); + mod.loadTime[3] := SHORT(tm.tm_hour); + mod.loadTime[4] := SHORT(tm.tm_min); + mod.loadTime[5] := SHORT(tm.tm_sec); + tm := NIL; + + IF ~(init IN mod.opts) THEN InitModule(mod) END + END RegisterMod; + + PROCEDURE^ Collect*; + + PROCEDURE UnloadMod* (mod: Module); + VAR i: INTEGER; t: Command; + BEGIN + IF mod.refcnt = 0 THEN + t := mod.term; mod.term := NIL; + IF t # NIL THEN t() END; (* terminate module *) + i := 0; + WHILE i < mod.nofptrs DO (* release global pointers *) + S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) + END; +(* + ReleaseIPtrs(mod); (* release global interface pointers *) +*) + Collect; (* call finalizers *) + i := 0; + WHILE i < mod.nofimps DO (* release imported modules *) + IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; + INC(i) + END; + mod.refcnt := -1; + IF dyn IN mod.opts THEN (* release memory *) + InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) + END + END + END UnloadMod; + + (* -------------------- dynamic procedure call --------------------- *) (* COMPILER DEPENDENT *) + + PROCEDURE [1] PUSH (p: INTEGER) 050H; (* push AX *) + PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H; (* call AX *) + PROCEDURE [1] RETI (): LONGINT; + PROCEDURE [1] RETR (): REAL; + + (* + type par + 32 bit scalar value + 64 bit scalar low hi + var scalar address + record address tag + array address size + open array address length .. length + *) + + PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; + VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL; + BEGIN + p := sig.num; + WHILE p > 0 DO (* push parameters from right to left *) + DEC(p); + typ := sig.par[p].struct; + kind := sig.par[p].id MOD 16; + IF (S.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN (* scalar *) + IF (kind = 10) & ((S.VAL(INTEGER, typ) = 8) OR (S.VAL(INTEGER, typ) = 10)) THEN (* 64 bit *) + DEC(n); PUSH(par[n]) (* push hi word *) + END; + DEC(n); PUSH(par[n]) (* push value/address *) + ELSIF typ.id MOD 4 = 1 THEN (* record *) + IF kind # 10 THEN (* var par *) + DEC(n); PUSH(par[n]); (* push tag *) + DEC(n); PUSH(par[n]) (* push address *) + ELSE + DEC(n, 2); (* skip tag *) + S.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) + S.MOVE(par[n], sp, typ.size) (* copy to stack *) + END + ELSIF typ.size = 0 THEN (* open array *) + size := typ.id DIV 16 MOD 16; (* number of open dimensions *) + WHILE size > 0 DO + DEC(size); DEC(n); PUSH(par[n]) (* push length *) + END; + DEC(n); PUSH(par[n]) (* push address *) + ELSE (* fix array *) + IF kind # 10 THEN (* var par *) + DEC(n, 2); PUSH(par[n]) (* push address *) + ELSE + DEC(n); size := par[n]; DEC(n); + S.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) + S.MOVE(par[n], sp, size) (* copy to stack *) + END + END + END; + ASSERT(n = 0); + IF S.VAL(INTEGER, sig.retStruct) = 7 THEN (* shortreal *) + CALL(adr); + RETURN S.VAL(INTEGER, SHORT(RETR())) (* return value in fpu register *) + ELSIF S.VAL(INTEGER, sig.retStruct) = 8 THEN (* real *) + CALL(adr); r := RETR(); + RETURN S.VAL(LONGINT, r) (* return value in fpu register *) + ELSE + CALL(adr); + RETURN RETI() (* return value in integer registers *) + END + END Call; + + (* -------------------- reference information (portable) --------------------- *) + + PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR); + BEGIN + S.GET(ref, ch); INC(ref) + END RefCh; + + PROCEDURE RefNum (VAR ref: INTEGER; VAR x: INTEGER); + VAR s, n: INTEGER; ch: SHORTCHAR; + BEGIN + s := 0; n := 0; RefCh(ref, ch); + WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; + x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) + END RefNum; + + PROCEDURE RefName (VAR ref: INTEGER; VAR n: Name); + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; RefCh(ref, ch); + WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; + n[i] := 0X + END RefName; + + PROCEDURE GetRefProc* (VAR ref: INTEGER; VAR adr: INTEGER; VAR name: Name); + VAR ch: SHORTCHAR; + BEGIN + S.GET(ref, ch); + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) + END; + WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) + INC(ref); RefNum(ref, adr); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) + ELSE adr := 0 + END + END GetRefProc; + + (* A. V. Shiryaev, 2012.11 *) + PROCEDURE CheckRefVarReadable (ref: INTEGER): BOOLEAN; + VAR ok: BOOLEAN; ch: SHORTCHAR; + p: INTEGER; (* address *) + + PROCEDURE Get; + BEGIN + IF ok THEN + IF IsReadable(ref, ref+1) THEN (* S.GET(ref, ch); INC(ref) *) RefCh(ref, ch) + ELSE ok := FALSE + END + END + END Get; + + PROCEDURE Num; + BEGIN + Get; WHILE ok & (ORD(ch) >= 128) DO Get END + END Num; + + PROCEDURE Name; + BEGIN + Get; WHILE ok & (ch # 0X) DO Get END + END Name; + + BEGIN + ok := TRUE; + Get; (* mode *) + IF ok & (ch >= 0FDX) THEN + Get; (* form *) + IF ok & (ch = 10X) THEN + IF IsReadable(ref, ref + 4) THEN (* desc *) + S.GET(ref, p); INC(ref, 4); + ok := IsReadable(p + 2 * 4, p + 3 * 4) (* desc.id *) + ELSE ok := FALSE + END + END; + Num; Name + END; + RETURN ok + END CheckRefVarReadable; + + PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type; + VAR adr: INTEGER; VAR name: Name); + BEGIN + IF CheckRefVarReadable(ref) THEN + S.GET(ref, mode); desc := NIL; + IF mode >= 0FDX THEN + mode := SHORT(CHR(ORD(mode) - 0FCH)); + INC(ref); RefCh(ref, form); + IF form = 10X THEN + S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) + END; + RefNum(ref, adr); RefName(ref, name) + ELSE + mode := 0X; form := 0X; adr := 0 + END + ELSE + Msg("Kernel.GetRefVar failed!"); Int(ref); + mode := 0X; form := 0X; adr := 0 + END + END GetRefVar; + + PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; + VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Name; + BEGIN + ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); + WHILE ch # 0X DO + WHILE (ch > 0X) & (ch < 0FCX) DO + INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); + IF ad > codePos THEN RETURN pos END; + INC(pos, d); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END; + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) + END + END; + RETURN -1 + END SourcePos; + + (* -------------------- dynamic link libraries --------------------- *) + +(* + PROCEDURE DlOpen (name: ARRAY OF SHORTCHAR): Dl.HANDLE; + CONST flags = Dl.RTLD_LAZY + Dl.RTLD_GLOBAL; + VAR h: Dl.HANDLE; + i: INTEGER; + BEGIN + h := Dl.NULL; + i := 0; WHILE (i < LEN(name)) & (name[i] # 0X) DO INC(i) END; + IF i < LEN(name) THEN + h := Dl.dlopen(name, flags); + WHILE (h = Dl.NULL) & (i > 0) DO + DEC(i); + WHILE (i > 0) & (name[i] # '.') DO DEC(i) END; + IF i > 0 THEN + name[i] := 0X; + h := Dl.dlopen(name, flags); + (* IF h # Dl.NULL THEN Msg(name$) END *) + END + END + END; + RETURN h + END DlOpen; +*) + + PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN); + VAR h: Dl.HANDLE; + BEGIN + ok := FALSE; + h := Dl.dlopen(name, Dl.RTLD_LAZY + Dl.RTLD_GLOBAL); + IF h # Dl.NULL THEN ok := TRUE END + END LoadDll; + + PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER; + VAR ad: INTEGER; h: Dl.HANDLE; + BEGIN + ad := 0; + IF mode IN {mVar, mProc} THEN + h := Dl.dlopen(dll, Dl.RTLD_LAZY+ Dl.RTLD_GLOBAL); + IF h # Dl.NULL THEN + ad := Dl.dlsym(h, name); + END + END; + RETURN ad + END ThisDllObj; + + (* -------------------- garbage collector (portable) --------------------- *) + + PROCEDURE Mark (this: Block); + VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; + BEGIN + IF ~ODD(S.VAL(INTEGER, this.tag)) THEN + father := NIL; + LOOP + INC(S.VAL(INTEGER, this.tag)); + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + IF flag >= 2 THEN actual := this.first; this.actual := actual + ELSE actual := S.ADR(this.last) + END; + LOOP + offset := tag.ptroffs[0]; + IF offset < 0 THEN + INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) + IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) + INC(actual, tag.size); this.actual := actual + ELSE (* up *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + IF father = NIL THEN RETURN END; + son := this; this := father; + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + offset := tag.ptroffs[0]; + IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; + S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); + INC(S.VAL(INTEGER, tag), 4) + END + ELSE + S.GET(actual + offset, son); + IF son # NIL THEN + DEC(S.VAL(INTEGER, son), 4); + IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + S.PUT(actual + offset, father); father := this; this := son; + EXIT + END + END; + INC(S.VAL(INTEGER, tag), 4) + END + END + END + END + END Mark; + + PROCEDURE MarkGlobals; + VAR m: Module; i, p: INTEGER; + BEGIN + m := modList; + WHILE m # NIL DO + IF m.refcnt >= 0 THEN + i := 0; + WHILE i < m.nofptrs DO + S.GET(m.varBase + m.ptrs[i], p); INC(i); + IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END + END + END; + m := m.next + END + END MarkGlobals; + +(* This is the specification for the code procedure following below: + + PROCEDURE Next (b: Block): Block; (* next block in same cluster *) + VAR size: INTEGER; + BEGIN + S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); + IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; + RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) + END Next; + +*) + PROCEDURE [code] Next (b: Block): Block (* next block in same cluster *) + (* + MOV ECX,[EAX] b.tag + AND CL,0FCH b.tag DIV * 4 + MOV ECX,[ECX] size + TESTB [EAX],02H ODD(b.tag DIV 2) + JE L1 + ADD ECX,[EAX,4] size + b.last + SUB ECX,EAX + SUB ECX,4 size + b.last - ADR(b.last) + L1: + ADD ECX,19 size + 19 + AND CL,0F0H (size + 19) DIV 16 * 16 + ADD EAX,ECX b + size + *) + 08BH, 008H, + 080H, 0E1H, 0FCH, + 08BH, 009H, + 0F6H, 000H, 002H, + 074H, 008H, + 003H, 048H, 004H, + 029H, 0C1H, + 083H, 0E9H, 004H, + 083H, 0C1H, 013H, + 080H, 0E1H, 0F0H, + 001H, 0C8H; + + PROCEDURE CheckCandidates; + (* pre: nofcand > 0 *) + VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; + BEGIN + (* sort candidates (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; + REPEAT h := h DIV 3; i := h; + WHILE i < nofcand DO p := candidates[i]; j := i; + WHILE (j >= h) & (candidates[j-h] > p) DO + candidates[j] := candidates[j-h]; j := j-h + END; + candidates[j] := p; INC(i) + END + UNTIL h = 1; + (* sweep *) + c := root; i := 0; + WHILE c # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); + end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; + WHILE candidates[i] < S.VAL(INTEGER, blk) DO + INC(i); + IF i = nofcand THEN RETURN END + END; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF candidates[i] < S.VAL(INTEGER, next) THEN + IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) + & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN + Mark(blk) + END; + REPEAT + INC(i); + IF i = nofcand THEN RETURN END + UNTIL candidates[i] >= S.VAL(INTEGER, next) + END; + IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) + & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) + Mark(blk) + END; + blk := next + END; + c := c.next + END + END CheckCandidates; + + PROCEDURE MarkLocals; + VAR sp, p, min, max: INTEGER; c: Cluster; + BEGIN + S.GETREG(FP, sp); nofcand := 0; c := root; + WHILE c.next # NIL DO c := c.next END; + min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; + WHILE sp < baseStack DO + S.GET(sp, p); + IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN + candidates[nofcand] := p; INC(nofcand); + IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END + END; + INC(sp, 4) + END; + candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) + IF nofcand > 0 THEN CheckCandidates END + END MarkLocals; + + PROCEDURE MarkFinObj; + VAR f: FList; + BEGIN + wouldFinalize := FALSE; + f := finalizers; + WHILE f # NIL DO + IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END; + f := hotFinalizers; + WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END + END MarkFinObj; + + PROCEDURE CheckFinalizers; + VAR f, g, h, k: FList; + BEGIN + f := finalizers; g := NIL; + IF hotFinalizers = NIL THEN k := NIL + ELSE + k := hotFinalizers; + WHILE k.next # NIL DO k := k.next END + END; + WHILE f # NIL DO + h := f; f := f.next; + IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN + IF g = NIL THEN finalizers := f ELSE g.next := f END; + IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; + k := h; h.next := NIL + ELSE g := h + END + END; + h := hotFinalizers; + WHILE h # NIL DO Mark(h.blk); h := h.next END + END CheckFinalizers; + + PROCEDURE ExecFinalizer (a, b, c: INTEGER); + VAR f: FList; fin: PROCEDURE(this: ANYPTR); + BEGIN + f := S.VAL(FList, a); + IF f.aiptr THEN (* ArrFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) *) + ELSE + S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) + IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; +(* + IF f.iptr THEN RecFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) END +*) + END + END ExecFinalizer; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) + + PROCEDURE CallFinalizers; + VAR f: FList; + BEGIN + WHILE hotFinalizers # NIL DO + f := hotFinalizers; hotFinalizers := hotFinalizers.next; + Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) + END; + wouldFinalize := FALSE + END CallFinalizers; + + PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) + VAR i: INTEGER; + BEGIN + blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); + i := MIN(N - 1, (blk.size DIV 16)); + blk.next := free[i]; free[i] := blk + END Insert; + + PROCEDURE Sweep (dealloc: BOOLEAN); + VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; + BEGIN + cluster := root; last := NIL; allocated := 0; + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + WHILE cluster # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); + end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; + fblk := NIL; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF ODD(S.VAL(INTEGER, blk.tag)) THEN + IF fblk # NIL THEN + Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); + fblk := NIL + END; + DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) + INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) + ELSIF fblk = NIL THEN + fblk := S.VAL(FreeBlock, blk) + END; + blk := next + END; + IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) + c := cluster; cluster := cluster.next; + IF last = NIL THEN root := cluster ELSE last.next := cluster END; + FreeHeapMem(c) + ELSE + IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; + last := cluster; cluster := cluster.next + END + END; + (* reverse free list *) + i := N; + REPEAT + DEC(i); + b := free[i]; fblk := sentinel; + WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; + free[i] := fblk + UNTIL i = 0 + END Sweep; + + PROCEDURE Collect*; + BEGIN + IF root # NIL THEN + CallFinalizers; (* trap cleanup *) + IF debug & (watcher # NIL) THEN watcher(1) END; + MarkGlobals; + MarkLocals; + CheckFinalizers; + Sweep(TRUE); + CallFinalizers + END + END Collect; + + PROCEDURE FastCollect*; + BEGIN + IF root # NIL THEN + IF debug & (watcher # NIL) THEN watcher(2) END; + MarkGlobals; + MarkLocals; + MarkFinObj; + Sweep(FALSE) + END + END FastCollect; + + PROCEDURE WouldFinalize* (): BOOLEAN; + BEGIN + RETURN wouldFinalize + END WouldFinalize; + + (* --------------------- memory allocation (portable) -------------------- *) + + PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + IF debug & (watcher # NIL) THEN watcher(3) END; + s := size - 4; + i := MIN(N - 1, s DIV 16); + WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; + b := free[i]; l := NIL; + WHILE b.size < s DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + RETURN b + END OldBlock; + + PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := limit - 4; + i := 0; + REPEAT + b := free[i]; l := NIL; + WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + INC(i) + UNTIL (b # NIL) OR (i = N); + RETURN b + END LastBlock; + + PROCEDURE NewBlock (size: INTEGER): Block; + VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; + BEGIN + ASSERT(size>=0,20); + IF size >7FFFFFECH THEN RETURN NIL END; (*20120822 Marc*) + tsize := (size + 19) DIV 16 * 16; + b := OldBlock(tsize); (* 1) search for free block *) + IF b = NIL THEN + FastCollect; b := OldBlock(tsize); (* 2) collect *) + IF b = NIL THEN + Collect; b := OldBlock(tsize); (* 2a) fully collect *) + END; + IF b = NIL THEN + AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) + IF new # NIL THEN + IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN + new.next := root; root := new + ELSE + c := root; + WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; + new.next := c.next; c.next := new + END; + b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); + b.size := (new.size - 12) DIV 16 * 16 - 4 + ELSE + RETURN NIL (* 4) give up *) + END + END + END; + (* b # NIL *) + a := b.size + 4 - tsize; + IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; + IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; + INC(allocated, tsize); + RETURN S.VAL(Block, b) + END NewBlock; + + PROCEDURE Allocated* (): INTEGER; + BEGIN + RETURN allocated + END Allocated; + + PROCEDURE Used* (): INTEGER; + BEGIN + RETURN used + END Used; + + PROCEDURE Root* (): INTEGER; + BEGIN + RETURN S.VAL(INTEGER, root) + END Root; + + + (* -------------------- Trap Handling --------------------- *) + + PROCEDURE^ InitFpu; + + PROCEDURE Start* (code: Command); + BEGIN + restart := code; +(* + S.GETREG(SP, baseStack); (* save base stack *) +*) + res := Libc.sigsetjmp(loopContext, Libc.TRUE); + code() + END Start; + + PROCEDURE Quit* (exitCode: INTEGER); + VAR m: Module; term: Command; t: BOOLEAN; + res: INTEGER; + BEGIN + trapViewer := NIL; trapChecker := NIL; restart := NIL; + t := terminating; terminating := TRUE; m := modList; + WHILE m # NIL DO (* call terminators *) + IF ~static OR ~t THEN + term := m.term; m.term := NIL; + IF term # NIL THEN term() END + END; +(* + ReleaseIPtrs(m); +*) + m := m.next + END; + CallFinalizers; + hotFinalizers := finalizers; finalizers := NIL; + CallFinalizers; +(* + IF ~inDll THEN + RemoveExcp(excpPtr^); + WinApi.ExitProcess(exitCode) (* never returns *) + END +*) + + res := Libc.fflush(0); + Libc.exit(exitCode) + END Quit; + + PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); + VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; + BEGIN + title := "Error xy"; + title[6] := CHR(id DIV 10 + ORD("0")); + title[7] := CHR(id MOD 10 + ORD("0")); +(* + res := WinApi.MessageBoxW(0, str, title, {}); +*) + text := SHORT(str$); + res := MessageBox(title$, SHORT(str), {mbOk}); +(* + IF ~inDll THEN RemoveExcp(excpPtr^) END; +*) +(* + WinApi.ExitProcess(1) +*) + Libc.exit(1) + (* never returns *) + END FatalError; + + PROCEDURE DefaultTrapViewer; + VAR len, ref, end, x, a, b, c: INTEGER; mod: Module; + name: Name; out: ARRAY 1024 OF SHORTCHAR; + + PROCEDURE WriteString (s: ARRAY OF SHORTCHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + BEGIN + IF len + n < LEN(out) THEN + i := len + n - 1; + WHILE i >= len DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) + END; + INC(len, n) + END + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END + END WriteLn; + + BEGIN + len := 0; + IF err = 129 THEN WriteString("invalid with") + ELSIF err = 130 THEN WriteString("invalid case") + ELSIF err = 131 THEN WriteString("function without return") + ELSIF err = 132 THEN WriteString("type guard") + ELSIF err = 133 THEN WriteString("implied type guard") + ELSIF err = 134 THEN WriteString("value out of range") + ELSIF err = 135 THEN WriteString("index out of range") + ELSIF err = 136 THEN WriteString("string too long") + ELSIF err = 137 THEN WriteString("stack overflow") + ELSIF err = 138 THEN WriteString("integer overflow") + ELSIF err = 139 THEN WriteString("division by zero") + ELSIF err = 140 THEN WriteString("infinite real result") + ELSIF err = 141 THEN WriteString("real underflow") + ELSIF err = 142 THEN WriteString("real overflow") + ELSIF err = 143 THEN WriteString("undefined real result") + ELSIF err = 200 THEN WriteString("keyboard interrupt") + ELSIF err = 202 THEN WriteString("illegal instruction: "); + WriteHex(val, 4) + ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 205 THEN WriteString("illegal execution [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) + ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; + WriteString("trap #"); WriteHex(err, 3) + END; + a := pc; b := fp; c := 12; + REPEAT + WriteLn; WriteString("- "); + mod := 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 + WriteString(mod.name); ref := mod.refs; + REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end); + IF a < end THEN + WriteString("."); WriteString(name) + END + ELSE + WriteString("("); WriteString(mod.name); WriteString(")") + END; + WriteString(" ") + END; + WriteString("(pc="); WriteHex(a, 8); + WriteString(", fp="); WriteHex(b, 8); WriteString(")"); + IF (b >= sp) & (b < stack) THEN + S.GET(b+4, a); (* stacked pc *) + S.GET(b, b); (* dynamic link *) + DEC(c) + ELSE c := 0 + END + UNTIL c = 0; + out[len] := 0X; + x := MessageBox("BlackBox", out$, {mbOk}) + END DefaultTrapViewer; + + PROCEDURE TrapCleanup; + VAR t: TrapCleaner; + BEGIN + WHILE trapStack # NIL DO + t := trapStack; trapStack := trapStack.next; t.Cleanup + END; + IF (trapChecker # NIL) & (err # 128) THEN trapChecker END + END TrapCleanup; + + PROCEDURE SetTrapGuard* (on: BOOLEAN); + BEGIN + guarded := on + END SetTrapGuard; + + PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); + VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf; + BEGIN + oldContext := currentTryContext; + res := Libc.sigsetjmp(context, Libc.TRUE); + currentTryContext := S.ADR(context); + IF res = 0 THEN (* first time around *) + h(a, b, c); + ELSIF res = trapReturn THEN (* after a trap *) + ELSE + HALT(100) + END; + currentTryContext := oldContext; + END Try; + + (* -------------------- Initialization --------------------- *) + + PROCEDURE InitFpu; (* COMPILER DEPENDENT *) + (* could be eliminated, delayed for backward compatibility *) + VAR cw: SET; + BEGIN + FINIT; + FSTCW; + (* denorm, underflow, precision, zero div, overflow masked *) + (* invalid trapped *) + (* round to nearest, temp precision *) + cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9}; + FLDCW + END InitFpu; + + PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t); + BEGIN + IF isReadableCheck THEN + isReadableCheck := FALSE; + Msg("~IsReadable"); + Libc.siglongjmp(isReadableContext, 1) + END; + + (* + S.GETREG(SP, sp); + S.GETREG(FP, fp); + *) + stack := baseStack; + + sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *) + fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *) + pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *) + val := siginfo.si_addr; + + (* + Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno); + Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int); + *) + err := sig; + IF trapped THEN DefaultTrapViewer END; + CASE sig OF + Libc.SIGINT: + err := 200 (* Interrupt (ANSI). *) + | Libc.SIGILL: (* Illegal instruction (ANSI). *) + err := 202; val := 0; + IF IsReadable(pc, pc + 4) THEN + S.GET(pc, val); + IF val MOD 100H = 8DH THEN (* lea reg,reg *) + IF val DIV 100H MOD 100H = 0F0H THEN + err := val DIV 10000H MOD 100H (* trap *) + ELSIF val DIV 1000H MOD 10H = 0EH THEN + err := 128 + val DIV 100H MOD 10H (* run time error *) + END + END + END + | Libc.SIGFPE: + CASE siginfo.si_code OF + 0: (* TODO: ?????? *) + IF siginfo.si_int = 8 THEN + err := 139 + ELSIF siginfo.si_int = 0 THEN + err := 143 + END + | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *) + | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *) + | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *) + | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *) + | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *) + | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *) + | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *) + | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *) + ELSE + END + | Libc.SIGSEGV: (* Segmentation violation (ANSI). *) + err := 203 + ELSE + END; + INC(trapCount); + InitFpu; + TrapCleanup; + IF err # 128 THEN + IF (trapViewer = NIL) OR trapped THEN + DefaultTrapViewer + ELSE + trapped := TRUE; + trapViewer(); + trapped := FALSE + END + END; + IF currentTryContext # NIL THEN (* Try failed *) + Libc.siglongjmp(currentTryContext, trapReturn) + ELSE + IF restart # NIL THEN (* Start failed *) + Libc.siglongjmp(loopContext, trapReturn) + END; + Quit(1); (* FIXME *) + END; + trapped := FALSE + END TrapHandler; + + PROCEDURE InstallSignals*; + VAR sa, old: Libc.sigaction_t; res, i: INTEGER; +(* + sigstk: Libc.stack_t; + errno: INTEGER; +*) + BEGIN +(* + (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *) + sigstk.ss_sp := sigStack; + sigstk.ss_size := sigStackSize; + sigstk.ss_flags := 0; + res := Libc.sigaltstack(sigstk, NIL); + IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!"); + S.GET( Libc.__errno_location(), errno ); + Int(errno); + Libc.exit(1) + END; +*) + + sa.sa_sigaction := TrapHandler; +(* + res := LinLibc.sigemptyset(S.ADR(sa.sa_mask)); +*) + res := Libc.sigfillset(S.ADR(sa.sa_mask)); + sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *) + (* + IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END; + IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END; + IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END; + IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END; + IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END; + IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END; + *) + (* respond to all possible signals *) + FOR i := 1 TO Libc._NSIG - 1 DO + IF (i # Libc.SIGKILL) + & (i # Libc.SIGSTOP) + & (i # Libc.SIGWINCH) + THEN + IF Libc.sigaction(i, sa, old) # 0 THEN (* Msg("failed to install signal"); Int(i) *) END; + END + END + END InstallSignals; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN +(* + (* for sigaltstack *) + sigStack := Libc.calloc(1, sigStackSize); + IF sigStack = Libc.NULL THEN + Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!"); + Libc.exit(1) + END; +*) + (* for mmap *) + zerofd := Libc.open("/dev/zero", Libc.O_RDWR, {0..8}); + IF zerofd < 0 THEN + Msg("ERROR: Kernel.Init: can not open /dev/zero!"); + Libc.exit(1) + END; + (* for mprotect *) + pageSize := Libc.sysconf(Libc._SC_PAGESIZE); + IF pageSize < 0 THEN + Msg("ERROR: Kernel.Init: pageSize < 0!"); + Libc.exit(1) + END; + + isReadableCheck := FALSE; + + InstallSignals; (* init exception handling *) + currentTryContext := NIL; + + allocated := 0; total := 0; used := 0; + sentinelBlock.size := MAX(INTEGER); + sentinel := S.ADR(sentinelBlock); + +(* + S.PUTREG(ML, S.ADR(modList)); +*) + + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + + IF inDll THEN +(* + baseStack := FPageWord(4); (* begin of stack segment *) +*) + END; + InitFpu; + IF ~static THEN + InitModule(modList); + IF ~inDll THEN Quit(1) END + END; + told := 0; shift := 0 + END Init; + +BEGIN + IF modList = NIL THEN (* only once *) + S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *) + IF bootInfo # NIL THEN + modList := bootInfo.modList (* boot loader initializes the bootInfo struct *) + ELSE + S.GETREG(ML, modList) (* linker loads module list to BX *) + END; + static := init IN modList.opts; + inDll := dll IN modList.opts; + Init + END +CLOSE + IF ~terminating THEN + terminating := TRUE; + Quit(0) + END +END Kernel. diff --git a/Trurl-based/_Linux_/dev0 b/Trurl-based/_Linux_/dev0 new file mode 120000 index 0000000..b787eae --- /dev/null +++ b/Trurl-based/_Linux_/dev0 @@ -0,0 +1 @@ +Lin/Rsrc/loader/dev0 \ No newline at end of file diff --git a/Trurl-based/_Linux_/libBB.so b/Trurl-based/_Linux_/libBB.so new file mode 100644 index 0000000..44aec70 Binary files /dev/null and b/Trurl-based/_Linux_/libBB.so differ diff --git a/Trurl-based/_Linux_/libBB0.so b/Trurl-based/_Linux_/libBB0.so new file mode 100644 index 0000000..9a64b53 Binary files /dev/null and b/Trurl-based/_Linux_/libBB0.so differ diff --git a/Trurl-based/_Linux_GUI/Gtk2/Mod/GLib.odc b/Trurl-based/_Linux_GUI/Gtk2/Mod/GLib.odc new file mode 100644 index 0000000..a37e266 Binary files /dev/null and b/Trurl-based/_Linux_GUI/Gtk2/Mod/GLib.odc differ diff --git a/Trurl-based/_Linux_GUI/Gtk2/Mod/GObject.odc b/Trurl-based/_Linux_GUI/Gtk2/Mod/GObject.odc new file mode 100644 index 0000000..41dcc85 Binary files /dev/null and b/Trurl-based/_Linux_GUI/Gtk2/Mod/GObject.odc differ diff --git a/Trurl-based/_Linux_GUI/Gtk2/Mod/Gdk.odc b/Trurl-based/_Linux_GUI/Gtk2/Mod/Gdk.odc new file mode 100644 index 0000000..36c94f3 Binary files /dev/null and b/Trurl-based/_Linux_GUI/Gtk2/Mod/Gdk.odc differ diff --git a/Trurl-based/_Linux_GUI/Gtk2/Mod/Gtk.odc b/Trurl-based/_Linux_GUI/Gtk2/Mod/Gtk.odc new file mode 100644 index 0000000..10503e7 Binary files /dev/null and b/Trurl-based/_Linux_GUI/Gtk2/Mod/Gtk.odc differ diff --git a/Trurl-based/_Linux_GUI/Gtk2/Mod/Pango.odc b/Trurl-based/_Linux_GUI/Gtk2/Mod/Pango.odc new file mode 100644 index 0000000..a40e9e6 Binary files /dev/null and b/Trurl-based/_Linux_GUI/Gtk2/Mod/Pango.odc differ diff --git a/Trurl-based/_OpenBSD_/BlackBox b/Trurl-based/_OpenBSD_/BlackBox new file mode 120000 index 0000000..b4db3bb --- /dev/null +++ b/Trurl-based/_OpenBSD_/BlackBox @@ -0,0 +1 @@ +Lin/Rsrc/loader/BlackBox \ No newline at end of file diff --git a/Trurl-based/_OpenBSD_/Comm/Mod/V24.odc b/Trurl-based/_OpenBSD_/Comm/Mod/V24.odc new file mode 100644 index 0000000..722ff08 Binary files /dev/null and b/Trurl-based/_OpenBSD_/Comm/Mod/V24.odc differ diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Console.odc b/Trurl-based/_OpenBSD_/Host/Mod/Console.odc new file mode 100644 index 0000000..74fe243 Binary files /dev/null and b/Trurl-based/_OpenBSD_/Host/Mod/Console.odc differ diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Console.txt b/Trurl-based/_OpenBSD_/Host/Mod/Console.txt new file mode 100644 index 0000000..5bbb69e --- /dev/null +++ b/Trurl-based/_OpenBSD_/Host/Mod/Console.txt @@ -0,0 +1,156 @@ +MODULE HostConsole; + + (* THIS IS TEXT COPY OF Console.od *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Console, Libc := LinLibc, Iconv := LinIconv, HostLang, Kernel; + + CONST + defCh = '?'; + + TYPE + Cons = POINTER TO RECORD (Console.Console) END; + + VAR + cons: Cons; + e, d: Iconv.iconv_t; + + PROCEDURE ResetCodec (c: Iconv.iconv_t): BOOLEAN; + VAR res, fLen, tLen: Iconv.size_t; + BEGIN + fLen := 0; tLen := 0; + res := Iconv.iconv(c, NIL, fLen, NIL, tLen); + RETURN res # -1 + END ResetCodec; + + PROCEDURE (cons: Cons) ReadLn (OUT s: ARRAY OF CHAR); + CONST + maxLineLen = 1023; (* without null terminating shortchar *) + VAR + i: INTEGER; + str: Libc.PtrSTR; + ss: ARRAY maxLineLen+1 OF SHORTCHAR; + fR, fLen, tW, tLen: INTEGER; + st: BOOLEAN; + res: Iconv.size_t; + from: Iconv.PtrSTR; to: Iconv.PtrLSTR; + BEGIN + ss[LEN(ss)-1] := 0X; + str := Libc.fgets(ss, LEN(ss), SYSTEM.ADR(Libc.__sF[0]) (* stdin *)); + IF (str # NIL) & (ss[LEN(ss)-1] = 0X) THEN + fLen := LEN(ss$); + IF fLen < LEN(s) THEN + IF d # -1 THEN + IF ResetCodec(d) THEN + from := ss; to := s; tLen := (LEN(s) - 1) * SIZE(CHAR) (* 2 *); + res := Iconv.iconv_decode(d, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X + ELSE s[0] := 0X + END + ELSE s[0] := 0X + END + ELSE + i := 0; + WHILE (ss[i] > 0X) & (ss[i] < 80X) DO s[i] := ss[i]; INC(i) END; + IF ss[i] = 0X THEN s[i] := 0X + ELSE s[0] := 0X + END + END + ELSE s[0] := 0X + END + ELSE s[0] := 0X + END + END ReadLn; + + PROCEDURE Printf (IN s: ARRAY OF CHAR; len: INTEGER); + CONST + maxShortCharsPerChar = 4; + ssLen = 128; (* >= maxShortCharsPerChar + 1 *) + VAR + ss: ARRAY ssLen OF SHORTCHAR; + fR, fLen, tW, tLen, n: INTEGER; + res: INTEGER; + res1: Iconv.size_t; + from: Iconv.PtrLSTR; to: Iconv.PtrSTR; + BEGIN + fR := 0; from := s; + WHILE len > 0 DO + tW := 0; to := ss; + IF e # -1 THEN + tLen := LEN(ss) - 1; + n := MIN(len, tLen DIV maxShortCharsPerChar); + fLen := n * SIZE(CHAR) (* 2 *); + REPEAT + res1 := Iconv.iconv_encode(e, from, fLen, to, tLen); + IF ~((res1 >= 0) & (fLen = 0) & (tLen >= 0)) THEN + ASSERT(tLen >= 0, 100); + ASSERT(fLen >= SIZE(CHAR), 101); + ASSERT(ResetCodec(e), 102); + to[0] := defCh; to := SYSTEM.VAL(Iconv.PtrSTR, SYSTEM.VAL(INTEGER, to) + 1); + DEC(tLen); + from := SYSTEM.VAL(Iconv.PtrLSTR, SYSTEM.VAL(INTEGER, from) + SIZE(CHAR)); + DEC(fLen, SIZE(CHAR)) + END + UNTIL fLen = 0; + to[0] := 0X + ELSE + fLen := MIN(len, LEN(ss) - 1); n := fLen; + WHILE fLen > 0 DO + IF s[fR] < 80X THEN ss[tW] := SHORT(s[fR]) + ELSE ss[tW] := defCh + END; + INC(tW); + INC(fR); DEC(fLen) + END; + ss[tW] := 0X + END; + res := Libc.printf(ss); + res := Libc.fflush(Libc.NULL); + + len := len - n + END + END Printf; + + PROCEDURE (cons: Cons) WriteChar (c: CHAR); + VAR s: ARRAY 1 OF CHAR; + BEGIN + s[0] := c; + Printf(s, 1) + END WriteChar; + + PROCEDURE (cons: Cons) WriteStr (IN text: ARRAY OF CHAR); + BEGIN + Printf(text, LEN(text$)) + END WriteStr; + + PROCEDURE (cons: Cons) WriteLn; + BEGIN + Printf(0AX, 1) + END WriteLn; + + PROCEDURE Init; + BEGIN + IF Kernel.littleEndian THEN + e := Iconv.iconv_open(HostLang.enc, "UCS-2LE"); + d := Iconv.iconv_open("UCS-2LE", HostLang.enc) + ELSE + e := Iconv.iconv_open(HostLang.enc, "UCS-2BE"); + d := Iconv.iconv_open("UCS-2BE", HostLang.enc) + END; + + NEW(cons); + Console.SetConsole(cons) + END Init; + + PROCEDURE Close; + VAR res: INTEGER; + BEGIN + IF e # -1 THEN res := Iconv.iconv_close(e); e := -1 END; + IF d # -1 THEN res := Iconv.iconv_close(d); d := -1 END + END Close; + +BEGIN + Init +CLOSE + Close +END HostConsole. diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Dates.odc b/Trurl-based/_OpenBSD_/Host/Mod/Dates.odc new file mode 100644 index 0000000..c8e1d4f Binary files /dev/null and b/Trurl-based/_OpenBSD_/Host/Mod/Dates.odc differ diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Dates.txt b/Trurl-based/_OpenBSD_/Host/Mod/Dates.txt new file mode 100644 index 0000000..1246d0a --- /dev/null +++ b/Trurl-based/_OpenBSD_/Host/Mod/Dates.txt @@ -0,0 +1,92 @@ +MODULE HostDates; + + (* THIS IS TEXT COPY OF Dates.odc *) + (* DO NOT EDIT *) + + IMPORT + SYSTEM, LinLibc, Dates; + + (* Dates Hook *) + + TYPE + DatesHook = POINTER TO RECORD (Dates.Hook) END; + + (* + + Some conversions are needed between the Linux and the BlackBox representations of dates. The following + table shows the differences: + +(!) Linux BlackBox + year from year 1900 from year 0000 + month range 0-11 range 1-12 + weekday 0:sunday - 6:satruday 0:monday - 6:sunday + (!) *) + + PROCEDURE (h: DatesHook) DateToString (d: Dates.Date; format: INTEGER; OUT str: ARRAY OF CHAR); + VAR tm: LinLibc.tmDesc; sstr: ARRAY 64 OF SHORTCHAR; res: LinLibc.size_t; + BEGIN + ASSERT(format IN {Dates.short, Dates.abbreviated, Dates.long, Dates.plainAbbreviated, Dates.plainLong}, 20); + tm.tm_year := d.year - 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + tm.tm_mon := d.month - 1; tm.tm_mday := d.day; + tm.tm_wday := (Dates.DayOfWeek(d) + 1) MOD 7; + IF format = Dates.short THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%x", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.abbreviated THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%a, %b %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.long THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%A, %B %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSIF format = Dates.plainAbbreviated THEN + res := LinLibc.strftime(sstr, LEN(sstr), "%b %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + ELSE (* format = Dates.plainLong *) + res := LinLibc.strftime(sstr, LEN(sstr), "%B %d, %Y", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))) + END; + IF res > 0 THEN str := sstr$ELSE str := "invalid date" END + END DateToString; + + PROCEDURE (h: DatesHook) GetTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.localtime(time); + d.year := tm.tm_year + 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + d.month := tm.tm_mon + 1; d.day := tm.tm_mday; + t.hour := tm.tm_hour; t.minute := tm.tm_min; t.second := tm.tm_sec + END GetTime; + + PROCEDURE (h: DatesHook) GetUTCBias (OUT bias: INTEGER); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.localtime(time); (* call to localtime needed to make sure that timezone is set *) + bias := tm.tm_gmtoff DIV 60; (* Shiryaev A. V.: OpenBSD *) + END GetUTCBias; + + PROCEDURE (h: DatesHook) GetUTCTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR time: LinLibc.time_t; tm: LinLibc.tm; + BEGIN + time := LinLibc.time(NIL); + tm := LinLibc.gmtime(time); + d.year := tm.tm_year + 1900; (* Linux counts years from 1900 but BlackBox from 0000 *) + d.month := tm.tm_mon + 1; d.day := tm.tm_mday; + t.hour := tm.tm_hour; t.minute := tm.tm_min; t.second := tm.tm_sec + END GetUTCTime; + + PROCEDURE (h: DatesHook) TimeToString (t: Dates.Time; OUT str: ARRAY OF CHAR); + VAR tm: LinLibc.tmDesc; sstr: ARRAY 64 OF SHORTCHAR; res: LinLibc.size_t; + BEGIN + tm.tm_hour := t.hour; tm.tm_min := t.minute; tm.tm_sec := t.second; + res := LinLibc.strftime(sstr, LEN(sstr), "%X", SYSTEM.VAL(LinLibc.tm, SYSTEM.ADR(tm))); + IF res > 0 THEN str := sstr$ELSE str := "invalid time" END + END TimeToString; + + + PROCEDURE Init; + VAR + datesHook: DatesHook; + BEGIN + NEW(datesHook); Dates.SetHook(datesHook); + END Init; + +BEGIN + Init +END HostDates. diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Files.odc b/Trurl-based/_OpenBSD_/Host/Mod/Files.odc new file mode 100644 index 0000000..d0b5507 Binary files /dev/null and b/Trurl-based/_OpenBSD_/Host/Mod/Files.odc differ diff --git a/Trurl-based/_OpenBSD_/Host/Mod/Files.txt b/Trurl-based/_OpenBSD_/Host/Mod/Files.txt new file mode 100644 index 0000000..e4baa8d --- /dev/null +++ b/Trurl-based/_OpenBSD_/Host/Mod/Files.txt @@ -0,0 +1,1501 @@ +MODULE HostFiles; + + (* THIS IS TEXT COPY OF Files.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.11: filenames encoding translation implemented + *) + + IMPORT SYSTEM, Kernel, Files, LinLibc, Iconv := LinIconv; + + CONST + tempName = "odcxxxxx"; + docType = "odc"; + + serverVersion = TRUE; + + pathLen* = 260; + + nofbufs = 4; (* max number of buffers per file *) + bufsize = 2 * 1024; (* size of each buffer *) + + invalid = LinLibc.NULL; + + temp = 0; new = 1; shared = 2; hidden = 3; exclusive = 4; closed = 5; (* file states *) + create = -1; + + ok = 0; + invalidName = 1; + invalidNameErr = MAX(INTEGER); (* On Windows this is 123 *) + notFound = 2; + fileNotFoundErr = LinLibc.ENOENT; + pathNotFoundErr = LinLibc.ENOENT; + existsAlready = 3; + fileExistsErr = LinLibc.EEXIST; + alreadyExistsErr = LinLibc.EEXIST; (* is alreadyExistsErr needed? *) + writeProtected = 4; + writeProtectedErr = LinLibc.EACCES; + ioError = 5; (* same as LinLibc.EIO *) + accessDenied = 6; + accessDeniedErr = LinLibc.EACCES; + sharingErr = LinLibc.EACCES; + netAccessDeniedErr = LinLibc.EACCES; + notEnoughMem = 80; + notEnoughMemoryErr = LinLibc.ENOMEM; + notEnoughDisk = 81; + diskFullErr = LinLibc.EDQUOT; + tooManyOpenFilesErr = LinLibc.EMFILE; + + noMoreFilesErr = 18; + + cancel = -8; retry = -9; + + TYPE + FullName* = ARRAY pathLen OF CHAR; + + Locator* = POINTER TO RECORD (Files.Locator) + path-: FullName; (* without trailing "/" *) + maxLen-: INTEGER; (* maximum name length *) + caseSens-: BOOLEAN; (* case sensitive file compares *) + rootLen-: INTEGER (* for network version *) + END; + + Buffer = POINTER TO RECORD + dirty: BOOLEAN; + org, len: INTEGER; + data: ARRAY bufsize OF BYTE + END; + + File = POINTER TO RECORD (Files.File) + state: INTEGER; + name: FullName; + ref: LinLibc.PtrFILE; + loc: Locator; + swapper: INTEGER; (* index into file table / next buffer to swap *) + len: INTEGER; + bufs: ARRAY nofbufs OF Buffer; + t: LONGINT (* time stamp of last file operation *) + END; + + Reader = POINTER TO RECORD (Files.Reader) + base: File; + org, offset: INTEGER; + buf: Buffer + END; + + Writer = POINTER TO RECORD (Files.Writer) + base: File; + org, offset: INTEGER; + buf: Buffer + END; + + Directory = POINTER TO RECORD (Files.Directory) + temp, startup: Locator + END; + + Identifier = RECORD (Kernel.Identifier) + name: FullName + END; + + Searcher = RECORD (Kernel.Identifier) + t0: INTEGER; + f: File + END; + + Counter = RECORD (Kernel.Identifier) + count: INTEGER + END; + + ShortName = ARRAY pathLen * 4 OF SHORTCHAR; + + Encoding = ARRAY 32 OF SHORTCHAR; + + VAR + MapParamString*: PROCEDURE(in, p0, p1, p2: ARRAY OF CHAR; OUT out: ARRAY OF CHAR); + dir: Directory; + wildcard: Files.Type; + startupDir: FullName; + startupLen: INTEGER; + res: INTEGER; + e, d: Iconv.iconv_t; + + (* debugging functions *) + + PROCEDURE Msg (IN str: ARRAY OF CHAR); + VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER; + BEGIN + ss := SHORT(str); + l := LEN(ss$); + ss[l] := 0AX; ss[l + 1] := 0X; + res := LinLibc.printf(ss); + res := LinLibc.fflush(0) + END Msg; + + PROCEDURE Int (x: LONGINT); + VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR; + BEGIN + IF x # MIN(LONGINT) THEN + IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 + ELSE + a := "8085774586302733229"; s[0] := "-"; k := 1; + j := 0; WHILE a[j] # 0X DO INC(j) END + END; + ASSERT(k + j < LEN(s), 20); + REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X; + Msg(s); + END Int; + + (* end of debugging functions *) + + (* encoding translation *) + + PROCEDURE GetEnc (OUT enc: Encoding; OUT ok: BOOLEAN); + VAR env: LinLibc.PtrSTR; + i, j: INTEGER; + + PROCEDURE IsSLetter (c: SHORTCHAR): BOOLEAN; + BEGIN + RETURN (c >= 'a') & (c <= 'z') + END IsSLetter; + + PROCEDURE IsBLetter (c: SHORTCHAR): BOOLEAN; + BEGIN + RETURN (c >= 'A') & (c <= 'Z') + END IsBLetter; + + PROCEDURE IsValidEncChar (x: SHORTCHAR): BOOLEAN; + BEGIN + RETURN ((x >= 'A') & (x <= 'Z')) OR ((x >= '0') & (x <= '9')) OR (x = '-') OR (x = '_') + OR ((x >= 'a') & (x <= 'z')) + END IsValidEncChar; + + BEGIN + env := LinLibc.getenv("LANG"); + IF env # NIL THEN + IF env$ = "C" THEN + enc := "ASCII"; ok := TRUE + ELSE + IF IsSLetter(env[0]) & IsSLetter(env[1]) & (env[2] = '_') + & IsBLetter(env[3]) & IsBLetter(env[4]) & (env[5] = '.') THEN + i := 6; j := 0; + WHILE IsValidEncChar(env[i]) & (j < LEN(enc) - 1) DO + enc[j] := env[i]; + INC(j); INC(i) + END; + IF (env[i] = 0X) & (j < LEN(enc)) THEN + enc[j] := 0X; ok := TRUE + ELSE ok := FALSE + END + ELSE ok := FALSE + END + END + ELSE ok := FALSE + END + END GetEnc; + + PROCEDURE InitConv; + VAR enc: Encoding; ok: BOOLEAN; + BEGIN + GetEnc(enc, ok); + IF ok THEN + IF Kernel.littleEndian THEN + e := Iconv.iconv_open(enc, "UCS-2LE"); + d := Iconv.iconv_open("UCS-2LE", enc) + ELSE + e := Iconv.iconv_open(enc, "UCS-2BE"); + d := Iconv.iconv_open("UCS-2BE", enc) + END + ELSE e := -1; d := -1 + END + END InitConv; + + PROCEDURE CloseConv; + VAR res: INTEGER; + BEGIN + IF e # -1 THEN res := Iconv.iconv_close(e); e := -1 END; + IF d # -1 THEN res := Iconv.iconv_close(d); d := -1 END + END CloseConv; + + PROCEDURE ResetCodec (c: Iconv.iconv_t): BOOLEAN; + VAR res, fLen, tLen: Iconv.size_t; + BEGIN + ASSERT(c # -1, 20); + fLen := 0; tLen := 0; + res := Iconv.iconv(c, NIL, fLen, NIL, tLen); + RETURN res # -1 + END ResetCodec; + + PROCEDURE Short (IN f: FullName; OUT t: ShortName; OUT ok: BOOLEAN); + VAR fR, fLen, tLen: INTEGER; + from: Iconv.PtrLSTR; to: Iconv.PtrSTR; res: Iconv.size_t; + BEGIN + (* do not use encoder for basic set of chars *) + fR := 0; WHILE (f[fR] >= ' ') & (f[fR] <= '~') DO t[fR] := SHORT(f[fR]); INC(fR) END; + IF f[fR] = 0X THEN t[fR] := 0X; ok := TRUE + ELSIF (e # -1) & ResetCodec(e) THEN + from := f; to := t; fLen := LEN(f$) * SIZE(CHAR) (* 2 *); tLen := LEN(t) - 1; + res := Iconv.iconv_encode(e, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE + END + ELSE t[0] := 0X; ok := FALSE + END + END Short; + + PROCEDURE Long (IN f: ShortName; OUT t: FullName; OUT ok: BOOLEAN); + VAR fR, fLen, tLen: INTEGER; + from: Iconv.PtrSTR; to: Iconv.PtrLSTR; res: Iconv.size_t; + BEGIN + (* do not use decoder for basic set of chars *) + fR := 0; WHILE (f[fR] >= ' ') & (f[fR] <= '~') & (fR < LEN(t) - 1) DO t[fR] := f[fR]; INC(fR) END; + IF f[fR] = 0X THEN + IF fR < LEN(t) THEN t[fR] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE (* f is too long *) + END + ELSIF (d # -1) & ResetCodec(d) THEN + from := f; to := t; fLen := LEN(f$); tLen := (LEN(t) - 1) * SIZE(CHAR) (* 2 *); + res := Iconv.iconv_decode(d, from, fLen, to, tLen); + IF (res >= 0) & (fLen = 0) & (tLen >= 0) THEN to[0] := 0X; ok := TRUE + ELSE t[0] := 0X; ok := FALSE + END + ELSE t[0] := 0X; ok := FALSE + END + END Long; + + (* end of encoding translation *) + + + (* get error num from linux *) + PROCEDURE LinLibc_errno (): INTEGER; + VAR + addr, errno: INTEGER; + BEGIN + addr := LinLibc.__errno_location(); + SYSTEM.GET(addr, errno); + RETURN errno + END LinLibc_errno; + + PROCEDURE Error (n: INTEGER): INTEGER; + VAR res: INTEGER; + BEGIN + IF n = ok THEN res := ok + ELSIF n = invalidNameErr THEN res := invalidName + ELSIF (n = fileNotFoundErr) OR (n = pathNotFoundErr) THEN res := notFound + ELSIF (n = fileExistsErr) OR (n = alreadyExistsErr) THEN res := existsAlready + ELSIF n = writeProtectedErr THEN res := writeProtected + ELSIF (n = sharingErr) OR (n = accessDeniedErr) OR (n = netAccessDeniedErr) THEN res := accessDenied + ELSIF n = notEnoughMemoryErr THEN res := notEnoughMem + ELSIF (n = diskFullErr) OR (n = tooManyOpenFilesErr) THEN res := notEnoughDisk + ELSE res := -n + END; + RETURN res + END Error; + + PROCEDURE Diff (IN a, b: ARRAY OF CHAR; caseSens: BOOLEAN): INTEGER; + VAR i: INTEGER; cha, chb: CHAR; + BEGIN + i := 0; + REPEAT + cha := a[i]; chb := b[i]; INC(i); + IF cha # chb THEN + IF ~caseSens THEN + IF (cha >= "a") & ((cha <= "z") OR (cha >= 0E0X) & (cha <= 0FEX) & (cha # 0F7X)) THEN + cha := CAP(cha) + END; + IF (chb >= "a") & ((chb <= "z") OR (chb >= 0E0X) & (chb <= 0FEX) & (chb # 0F7X)) THEN + chb := CAP(chb) + END + END; + IF cha = "\" THEN cha := "/" END; + IF chb = "\" THEN chb := "/" END; + IF cha # chb THEN RETURN ORD(cha) - ORD(chb) END + END + UNTIL cha = 0X; + RETURN 0 + END Diff; + + PROCEDURE Stat (IN fname: FullName; VAR buf: LinLibc.stat_t; OUT res: INTEGER); + VAR s: ShortName; ok1: BOOLEAN; + BEGIN + Short(fname, s, ok1); + res := LinLibc.stat(s, buf); (* Shiryaev A. V.: OpenBSD *) + END Stat; + + PROCEDURE ModeToAttr (mode: SET; OUT attr: SET; OUT isDir: BOOLEAN); + CONST read = 8; write = 7; execute = 6; file = 15; (* bits for permissions for the current user (see man chmod) *) + BEGIN + attr := {}; + IF ~(write IN mode) THEN INCL(attr, Files.readOnly) END; + isDir := ~(file IN mode) (* see "man 2 stat" for details *) + END ModeToAttr; + + PROCEDURE NewLocator* (IN fname: ARRAY OF CHAR): Locator; + VAR loc: Locator; i: INTEGER; + BEGIN + NEW(loc); loc.path := fname$; i := 0; + WHILE loc.path[i] # 0X DO INC(i) END; + IF (loc.path[i-1] = "/") OR (loc.path[i-1] = "\") THEN loc.path[i-1] := 0X END; + loc.maxLen := LinLibc.NAME_MAX; loc.caseSens := TRUE; + RETURN loc + END NewLocator; + + PROCEDURE GetType (IN name: ARRAY OF CHAR; VAR type: Files.Type); + VAR i, j: INTEGER; ch: CHAR; + BEGIN + i := 0; j := 0; + WHILE name[i] # 0X DO INC(i) END; + WHILE (i > 0) & (name[i] # ".") DO DEC(i) END; + IF i > 0 THEN + INC(i); ch := name[i]; + WHILE (j < LEN(type) - 1) & (ch # 0X) DO + IF (ch >= "A") & (ch <= "Z") THEN ch := CHR(ORD(ch) + (ORD("a") - ORD("A"))) END; + type[j] := ch; INC(j); + INC(i); ch := name[i] + END + END; + type[j] := 0X + END GetType; + + PROCEDURE Append (IN path, name: ARRAY OF CHAR; type: Files.Type; max: INTEGER; + VAR res: ARRAY OF CHAR + ); + VAR i, j, n, m, dot: INTEGER; ch: CHAR; + BEGIN + i := 0; + WHILE path[i] # 0X DO res[i] := path[i]; INC(i) END; + IF path # "" THEN + ASSERT((res[i-1] # "/") & (res[i-1] # "\"), 100); + res[i] := "/"; INC(i) + END; + j := 0; ch := name[0]; n := 0; m := max; dot := -1; + IF max = 12 THEN m := 8 END; + WHILE (i < LEN(res) - 1) & (ch # 0X) DO + IF (ch = "/") OR (ch = "\") THEN + res[i] := ch; INC(i); n := 0; m := max; dot := -1; + IF max = 12 THEN m := 8 END + ELSIF (n < m) OR (ch = ".") & (n = 8) THEN + res[i] := ch; INC(i); INC(n); + IF ch = "." THEN dot := n; + IF max = 12 THEN m := n + 3 END + END + END; + INC(j); ch := name[j] + END; + IF (dot = -1) & (type # "") THEN + IF max = 12 THEN m := n + 4 END; + IF (n < m) & (i < LEN(res) - 1) THEN res[i] := "."; INC(i); INC(n); dot := n END + END; + IF n = dot THEN j := 0; + WHILE (n < m) & (i < LEN(res) - 1) & (type[j] # 0X) DO res[i] := type[j]; INC(i); INC(j) END + END; + res[i] := 0X + END Append; + + PROCEDURE CloseFileHandle (f: File; VAR res: INTEGER); + BEGIN + IF (f.ref = invalid) OR (LinLibc.fclose(f.ref) = 0) THEN res := ok (* !!! *) + ELSE res := LinLibc_errno() + END; + f.ref := invalid + END CloseFileHandle; + + PROCEDURE CloseFile (f: File; VAR res: INTEGER); + VAR s: INTEGER; n: ShortName; ok1: BOOLEAN; + BEGIN + IF f.state = exclusive THEN + f.Flush; + res := LinLibc.fflush(f.ref) + END; + s := f.state; f.state := closed; + CloseFileHandle (f, res); + IF (s IN {temp, new, hidden}) & (f.name # "") THEN + Short(f.name, n, ok1); + res := LinLibc.remove(n) + END + END CloseFile; + + PROCEDURE (f: File) FINALIZE; + VAR res: INTEGER; + BEGIN + IF f.state # closed THEN CloseFile(f, res) END + END FINALIZE; + + PROCEDURE (VAR id: Identifier) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := id.obj(File); + RETURN (f.state IN {shared, exclusive}) & (Diff(f.name, id.name, f.loc.caseSens) = 0) + END Identified; + + PROCEDURE ThisFile (IN name: FullName): File; + VAR id: Identifier; p: ANYPTR; + BEGIN + id.typ := SYSTEM.TYP(File); id.name := name$; + p := Kernel.ThisFinObj(id); + IF p # NIL THEN RETURN p(File) + ELSE RETURN NIL + END + END ThisFile; + + PROCEDURE (VAR s: Searcher) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := s.obj(File); + IF (f.ref # invalid) & ((s.f = NIL) OR (f.t < s.f.t)) THEN s.f := f END; + RETURN FALSE + END Identified; + + PROCEDURE SearchFileToClose; + VAR s: Searcher; p: ANYPTR; (* res: LONGINT; *) + BEGIN + s.typ := SYSTEM.TYP(File); s.f := NIL; + p := Kernel.ThisFinObj(s); + IF s.f # NIL THEN + res := LinLibc.fclose(s.f.ref); s.f.ref := invalid; + IF res = 0 THEN res := LinLibc_errno(); HALT(100) END + END + END SearchFileToClose; + + PROCEDURE ExistingFile (VAR n: ShortName): BOOLEAN; + VAR f: LinLibc.PtrFILE; ret: BOOLEAN; res: INTEGER; + BEGIN + f := LinLibc.fopen(n, "r"); + IF f # LinLibc.NULL THEN + res := LinLibc.fclose(f); + ret := TRUE + ELSE + ret := FALSE + END; + RETURN ret + END ExistingFile; + + PROCEDURE MoveFile (VAR old, new: ShortName; VAR res: INTEGER); (* as the WinApi.MoveFile *) + BEGIN + IF ExistingFile(new) THEN + res := fileExistsErr + ELSE + IF LinLibc.rename(old, new) = 0 THEN res := ok + ELSE res := LinLibc_errno(); + END + END + END MoveFile; + + PROCEDURE NewFileRef (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER); + VAR n: ShortName; ok1: BOOLEAN; + BEGIN + Short(name, n, ok1); + IF state = create THEN (* Create should fail if file already exists *) + IF ExistingFile(n) THEN + ref := invalid; res := fileExistsErr + ELSE + ref := LinLibc.fopen(n, "w+"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + END + ELSIF state = shared THEN + ref := LinLibc.fopen(n, "r"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + ELSE + ref := LinLibc.fopen(n, "r+"); + IF ref = invalid THEN res := LinLibc_errno() ELSE res := ok END + END + END NewFileRef; + + PROCEDURE OpenFile (state: INTEGER; VAR name: FullName; VAR ref, res: INTEGER); + BEGIN + NewFileRef(state, name, ref, res); + IF ref = invalid THEN + IF res = tooManyOpenFilesErr THEN + Kernel.Collect; + NewFileRef(state, name, ref, res); + IF ref = invalid THEN + res := LinLibc_errno(); + IF res = tooManyOpenFilesErr THEN + SearchFileToClose; + NewFileRef(state, name, ref, res); + END + ELSE res := ok + END + END + ELSE res := ok + END + END OpenFile; + + PROCEDURE GetTempFileName (IN path: FullName; OUT name: FullName; num: INTEGER); + VAR i: INTEGER; str: ARRAY 16 OF CHAR; + BEGIN + str := tempName; i := 7; + WHILE i > 2 DO + str[i] := CHR(num MOD 10 + ORD("0")); DEC(i); num := num DIV 10 + END; + Append(path, str, "", 8, name) + END GetTempFileName; + + PROCEDURE CreateFile (f: File; VAR res: INTEGER); + VAR num, n: INTEGER; + BEGIN + IF f.name = "" THEN + num := LinLibc.clock(); n := 200; + REPEAT + GetTempFileName(f.loc.path, f.name, num); INC(num); DEC(n); + OpenFile(create, f.name, f.ref, res) + UNTIL (res # fileExistsErr) OR (n = 0) + ELSE + OpenFile(f.state, f.name, f.ref, res) + END + END CreateFile; + + PROCEDURE Delete (IN fname, path: FullName; VAR res: INTEGER); + VAR num, n: INTEGER; f: File; new: FullName; attr: SET; fn, nn: ShortName; buf: LinLibc.stat_t; isDir: BOOLEAN; + ok1: BOOLEAN; + BEGIN + ASSERT(fname # "", 100); + f := ThisFile(fname); Short(fname, fn, ok1); + IF f = NIL THEN + IF LinLibc.remove(fn) = 0 THEN + res := ok + ELSE + res := LinLibc.fflush(0); + IF LinLibc.remove(fn) = 0 THEN res := ok ELSE res := LinLibc_errno() END + END + ELSE (* still in use => make it anonymous *) + IF f.ref # invalid THEN res := LinLibc.fclose(f.ref); f.ref := invalid END; (* !!! *) + Stat(f.name, buf, res); + ModeToAttr(buf.st_mode, attr, isDir); + IF (res = ok) & ~(Files.readOnly IN attr) THEN + num := LinLibc.clock(); n := 200; + REPEAT + GetTempFileName(path, new, num); INC(num); DEC(n); + Short(new, nn, ok1); + MoveFile(fn, nn, res); + UNTIL (res # fileExistsErr) OR (n = 0); + IF res = ok THEN + f.state := hidden; f.name := new$ + END + ELSE + res := writeProtectedErr + END + END + END Delete; + + PROCEDURE FlushBuffer (f: File; i: INTEGER); + VAR buf: Buffer; res: INTEGER; + BEGIN + buf := f.bufs[i]; + IF (buf # NIL) & buf.dirty THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + res := LinLibc.fseek(f.ref, buf.org, LinLibc.SEEK_SET); + IF LinLibc.fwrite(SYSTEM.ADR(buf.data), 1, buf.len, f.ref) < buf.len THEN + res := LinLibc_errno(); HALT(101) + END; + res := LinLibc.fflush(f.ref); + buf.dirty := FALSE; f.t := Kernel.Time() + END + END + END FlushBuffer; + + (* File *) + + PROCEDURE (f: File) NewReader (old: Files.Reader): Files.Reader; + VAR r: Reader; + BEGIN (* portable *) + ASSERT(f.state # closed, 20); + IF (old # NIL) & (old IS Reader) THEN r := old(Reader) ELSE NEW(r) END; + IF r.base # f THEN + r.base := f; r.buf := NIL; r.SetPos(0) + END; + r.eof := FALSE; + RETURN r + END NewReader; + + PROCEDURE (f: File) NewWriter (old: Files.Writer): Files.Writer; + VAR w: Writer; + BEGIN (* portable *) + ASSERT(f.state # closed, 20); ASSERT(f.state # shared, 21); + IF (old # NIL) & (old IS Writer) THEN w := old(Writer) ELSE NEW(w) END; + IF w.base # f THEN + w.base := f; w.buf := NIL; w.SetPos(f.len) + END; + RETURN w + END NewWriter; + + PROCEDURE (f: File) Length (): INTEGER; + BEGIN (* portable *) + RETURN f.len + END Length; + + PROCEDURE (f: File) Flush; + VAR i: INTEGER; + BEGIN (* portable *) + i := 0; WHILE i # nofbufs DO FlushBuffer(f, i); INC(i) END + END Flush; + + PROCEDURE GetPath (IN fname: FullName; OUT path: FullName); + VAR i: INTEGER; + BEGIN + path := fname$; i := LEN(path$); + WHILE (i > 0) & (path[i] # "\") & (path[i] # "/") & (path[i-1] # ":") DO DEC(i) END; + path[i] := 0X + END GetPath; + + PROCEDURE CreateDir (VAR path: FullName; VAR res: INTEGER); + VAR (*sec: KERNEL32.SecurityAttributes;*) p: FullName; s: ShortName; ok1: BOOLEAN; + BEGIN + ASSERT(path # "", 100); + Short(path, s, ok1); + res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *) + IF res # ok THEN + res := LinLibc_errno(); + IF (res = LinLibc.ENOTDIR) OR (res = LinLibc.ENOENT) THEN + GetPath(path, p); + CreateDir(p, res); (* recursive call *) + IF res = ok THEN + res := LinLibc.mkdir(s, {0..MAX(SET)}); (* full rights are masked with the umask, is this correct? *) + IF res # ok THEN res := LinLibc_errno() END + END + END + END + END CreateDir; + + PROCEDURE CheckPath (VAR path: FullName; ask: BOOLEAN; VAR res: INTEGER); + VAR s: ARRAY 300 OF CHAR; t: ARRAY 32 OF CHAR; + BEGIN + (*IF ask THEN + IF MapParamString # NIL THEN + MapParamString("#Host:CreateDir", path, "", "", s); + MapParamString("#Host:MissingDirectory", "", "", "", t) + ELSE + s := path$; t := "Missing Directory" + END; + res := Kernel.MessageBox(t, s, {Kernel.mbOk, Kernel.mbCancel}) + ELSE + res := Kernel.mbOk + END;*) + (*IF res = Kernel.mbOk THEN*) CreateDir(path, res) + (*ELSIF res = Kernel.mbCancel THEN res := cancel + END*) + END CheckPath; + + PROCEDURE CheckDelete (IN fname, path: FullName; ask: BOOLEAN; VAR res: INTEGER); + VAR s: ARRAY 300 OF CHAR; t: ARRAY 16 OF CHAR; + BEGIN + REPEAT + Delete(fname, path, res); + IF (res = writeProtectedErr) + OR (res = sharingErr) + OR (res = accessDeniedErr) + OR (res = netAccessDeniedErr) + THEN + (*IF ask THEN + IF MapParamString # NIL THEN + IF res = writeProtectedErr THEN + MapParamString("#Host:ReplaceWriteProtected", fname, 0DX, "", s) + ELSIF (res = accessDeniedErr) OR (res = netAccessDeniedErr) THEN + MapParamString("#Host:ReplaceAccessDenied", fname, 0DX, "", s) + ELSE + MapParamString("#Host:ReplaceInUse", fname, 0DX, "", s) + END; + MapParamString("#Host:FileError", "", "", "", t) + ELSE + s := fname$; t := "File Error" + END; + res := Kernel.MessageBox(t, s, {Kernel.mbRetry, Kernel.mbCancel}); + IF res = Kernel.mbCancel THEN res := cancel + ELSIF res = Kernel.mbRetry THEN res := retry + END + ELSE*) + res := cancel + (*END*) + ELSE + res := ok + END + UNTIL res # retry + END CheckDelete; + + PROCEDURE (f: File) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER); + VAR b: INTEGER; fname: FullName; fn, nn: ShortName; ok1: BOOLEAN; + BEGIN + ASSERT(f.state = new, 20); ASSERT(name # "", 21); + Append(f.loc.path, name, type, f.loc.maxLen, fname); + CheckDelete(fname, f.loc.path, ask, res); + ASSERT(res # 87, 100); + IF res = ok THEN + IF f.name = "" THEN + f.name := fname$; + OpenFile(create, f.name, f.ref, res); + IF res = ok THEN + f.state := exclusive; CloseFile(f, res); + Short(f.name, fn, ok1); + END + ELSE + f.state := exclusive; CloseFile(f, res); + Short(f.name, fn, ok1); Short(fname, nn, ok1); + MoveFile(fn, nn, res); + IF res = ok THEN + f.name := fname$; + Short(f.name, fn, ok1); + ELSE + ASSERT(res # 87, 101); + Short(f.name, fn, ok1); + b := LinLibc.remove(fn); + END + END + END; + res := Error(res) + END Register; + + PROCEDURE (f: File) Close; + VAR res: INTEGER; + BEGIN (* portable *) + IF f.state # closed THEN +(* + IF f.state = exclusive THEN + CloseFile(f, res) + ELSE + CloseFileHandle(f, res) + END +*) + CloseFile(f, res) + END + END Close; + + + (* Locator *) + + PROCEDURE (loc: Locator) This* (IN path: ARRAY OF CHAR): Locator; + VAR new: Locator; i: INTEGER; + BEGIN + IF path = "" THEN + NEW(new); new^ := loc^ + ELSIF path[0] = "/" THEN (* absolute path *) + new := NewLocator(path); + new.rootLen := 0 + ELSIF (path[0] = "\") OR (path[0] = "/") THEN + IF (path[1] = "\") OR (path[1] = "/") THEN (* network path *) + new := NewLocator(path); + new.rootLen := 0 + ELSE + NEW(new); new^ := dir.startup^; + new.res := invalidName; + RETURN new + END + ELSE + NEW(new); Append(loc.path, path, "", loc.maxLen, new.path); + i := 0; WHILE new.path[i] # 0X DO INC(i) END; + IF (new.path[i-1] = "/") OR (new.path[i-1] = "\") THEN new.path[i-1] := 0X END; + new.maxLen := loc.maxLen; + new.caseSens := loc.caseSens; + new.rootLen := loc.rootLen + END; + new.res := ok; + RETURN new + END This; + + (* Reader *) + + PROCEDURE (r: Reader) Base (): Files.File; + BEGIN (* portable *) + RETURN r.base + END Base; + + PROCEDURE (r: Reader) SetPos (pos: INTEGER); + VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer; + BEGIN + f := r.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25); + ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21); + offset := pos MOD bufsize; org := pos - offset; + i := 0; WHILE (i # nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END; + IF i # nofbufs THEN + buf := f.bufs[i]; + IF buf = NIL THEN (* create new buffer *) + NEW(buf); f.bufs[i] := buf; buf.org := -1 + END + ELSE (* choose an existing buffer *) + f.swapper := (f.swapper + 1) MOD nofbufs; + FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1 + END; + IF buf.org # org THEN + IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END; + count := buf.len; + IF count > 0 THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN + res := LinLibc_errno(); HALT(101) + END; + IF LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN + res := LinLibc_errno(); HALT(102) + END; + f.t := Kernel.Time() + END + END; + buf.org := org; buf.dirty := FALSE + END; + r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE + (* 0<= r.org <= r.base.len *) + (* 0 <= r.offset < bufsize *) + (* 0 <= r.buf.len <= bufsize *) + (* r.offset <= r.base.len *) + (* r.offset <= r.buf.len *) + END SetPos; + + PROCEDURE (r: Reader) Pos (): INTEGER; + BEGIN (* portable *) + ASSERT(r.base # NIL, 20); + RETURN r.org + r.offset + END Pos; + + PROCEDURE (r: Reader) ReadByte (OUT x: BYTE); + BEGIN (* portable *) + IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END; + IF r.offset < r.buf.len THEN + x := r.buf.data[r.offset]; INC(r.offset) + ELSE + x := 0; r.eof := TRUE + END + END ReadByte; + + PROCEDURE (r: Reader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER); + VAR from, to, count, restInBuf: INTEGER; + BEGIN (* portable *) + ASSERT(beg >= 0, 21); + IF len > 0 THEN + ASSERT(beg + len <= LEN(x), 23); + WHILE len # 0 DO + IF (r.org # r.buf.org) OR (r.offset >= bufsize) THEN r.SetPos(r.org + r.offset) END; + restInBuf := r.buf.len - r.offset; + IF restInBuf = 0 THEN r.eof := TRUE; RETURN + ELSIF restInBuf <= len THEN count := restInBuf + ELSE count := len + END; + from := SYSTEM.ADR(r.buf.data[r.offset]); to := SYSTEM.ADR(x) + beg; + SYSTEM.MOVE(from, to, count); + INC(r.offset, count); INC(beg, count); DEC(len, count) + END; + r.eof := FALSE + ELSE ASSERT(len = 0, 22) + END + END ReadBytes; + + (* Writer *) + + PROCEDURE (w: Writer) Base (): Files.File; + BEGIN (* portable *) + RETURN w.base + END Base; + + PROCEDURE (w: Writer) SetPos (pos: INTEGER); + VAR f: File; org, offset, i, count, res: INTEGER; buf: Buffer; + BEGIN + f := w.base; ASSERT(f # NIL, 20); ASSERT(f.state # closed, 25); + ASSERT(pos >= 0, 22); ASSERT(pos <= f.len, 21); + offset := pos MOD bufsize; org := pos - offset; + i := 0; WHILE (i # nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END; + IF i # nofbufs THEN + buf := f.bufs[i]; + IF buf = NIL THEN (* create new buffer *) + NEW(buf); f.bufs[i] := buf; buf.org := -1 + END + ELSE (* choose an existing buffer *) + f.swapper := (f.swapper + 1) MOD nofbufs; + FlushBuffer(f, f.swapper); buf := f.bufs[f.swapper]; buf.org := -1 + END; + IF buf.org # org THEN + IF org + bufsize > f.len THEN buf.len := f.len - org ELSE buf.len := bufsize END; + count := buf.len; + IF count > 0 THEN + IF f.ref = invalid THEN CreateFile(f, res) (* ASSERT(res = ok, 100) *) END; + IF f.ref # invalid THEN + IF LinLibc.fseek(f.ref, org, LinLibc.SEEK_SET) # 0 THEN + res := LinLibc_errno(); HALT(101) + END; + IF LinLibc.fread(SYSTEM.ADR(buf.data), 1, count, f.ref) < count THEN + res := LinLibc_errno(); HALT(102) + END; + f.t := Kernel.Time() + END + END; + buf.org := org; buf.dirty := FALSE + END; + w.buf := buf; w.org := org; w.offset := offset + (* 0<= w.org <= w.base.len *) + (* 0 <= w.offset < bufsize *) + (* 0 <= w.buf.len <= bufsize *) + (* w.offset <= w.base.len *) + (* w.offset <= w.buf.len *) + END SetPos; + + PROCEDURE (w: Writer) Pos (): INTEGER; + BEGIN (* portable *) + ASSERT(w.base # NIL, 20); + RETURN w.org + w.offset + END Pos; + + PROCEDURE (w: Writer) WriteByte (x: BYTE); + BEGIN (* portable *) + ASSERT(w.base.state # closed, 25); + IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END; + w.buf.data[w.offset] := x; w.buf.dirty := TRUE; + IF w.offset = w.buf.len THEN INC(w.buf.len); INC(w.base.len) END; + INC(w.offset) + END WriteByte; + + PROCEDURE (w: Writer) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER); + VAR from, to, count, restInBuf: INTEGER; + BEGIN (* portable *) + ASSERT(beg >= 0, 21); ASSERT(w.base.state # closed, 25); + IF len > 0 THEN + ASSERT(beg + len <= LEN(x), 23); + WHILE len # 0 DO + IF (w.org # w.buf.org) OR (w.offset >= bufsize) THEN w.SetPos(w.org + w.offset) END; + restInBuf := bufsize - w.offset; + IF restInBuf <= len THEN count := restInBuf ELSE count := len END; + from := SYSTEM.ADR(x) + beg; to := SYSTEM.ADR(w.buf.data[w.offset]); + SYSTEM.MOVE(from, to, count); + INC(w.offset, count); INC(beg, count); DEC(len, count); + IF w.offset > w.buf.len THEN INC(w.base.len, w.offset - w.buf.len); w.buf.len := w.offset END; + w.buf.dirty := TRUE + END + ELSE ASSERT(len = 0, 22) + END + END WriteBytes; + + (* Directory *) + + PROCEDURE (d: Directory) This (IN path: ARRAY OF CHAR): Files.Locator; + BEGIN + RETURN d.startup.This(path) + END This; + + PROCEDURE (d: Directory) New (loc: Files.Locator; ask: BOOLEAN): Files.File; + VAR f: File; res: INTEGER; attr: SET; isDir: BOOLEAN; buf: LinLibc.stat_t; + BEGIN + ASSERT(loc # NIL, 20); f := NIL; res := ok; + WITH loc: Locator DO + IF loc.path # "" THEN + Stat(loc.path, buf, res); + IF res # ok THEN + IF loc.res = 76 THEN CreateDir(loc.path, res) + ELSE CheckPath(loc.path, ask, res) + END + ELSE + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN res := fileExistsErr END + END + END; + IF res = ok THEN + NEW(f); f.loc := loc; f.name := ""; + f.state := new; f.swapper := -1; f.len := 0; f.ref := invalid + END + ELSE res := invalidNameErr + END; + loc.res := Error(res); + RETURN f + END New; + + PROCEDURE (d: Directory) Temp (): Files.File; + VAR f: File; + BEGIN + NEW(f); f.loc := d.temp; f.name := ""; + f.state := temp; f.swapper := -1; f.len := 0; f.ref := invalid; + RETURN f + END Temp; + + PROCEDURE GetShadowDir (loc: Locator; OUT dir: FullName); + VAR i, j: INTEGER; + BEGIN + dir := startupDir$; i := startupLen; j := loc.rootLen; + WHILE loc.path[j] # 0X DO dir[i] := loc.path[j]; INC(i); INC(j) END; + dir[i] := 0X + END GetShadowDir; + + PROCEDURE (d: Directory) Old (loc: Files.Locator; name: Files.Name; shrd: BOOLEAN): Files.File; + VAR res: INTEGER; f: File; ref: LinLibc.PtrFILE; fname: FullName; type: Files.Type; s: BYTE; buf: LinLibc.stat_t; + BEGIN + ASSERT(loc # NIL, 20); ASSERT(name # "", 21); + res := ok; f := NIL; + WITH loc: Locator DO + Append(loc.path, name, "", loc.maxLen, fname); + f := ThisFile(fname); + IF f # NIL THEN + IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL + ELSE loc.res := ok; RETURN f + END + END; + IF shrd THEN s := shared ELSE s := exclusive END; + OpenFile(s, fname, ref, res); + IF ((res = fileNotFoundErr) OR (res = pathNotFoundErr)) & (loc.rootLen > 0) THEN + GetShadowDir(loc, fname); + Append(fname, name, "", loc.maxLen, fname); + f := ThisFile(fname); + IF f # NIL THEN + IF ~shrd OR (f.state = exclusive) THEN loc.res := Error(sharingErr); RETURN NIL + ELSE loc.res := ok; RETURN f + END + END; + OpenFile(s, fname, ref, res) + END; + IF res = ok THEN + NEW(f); f.loc := loc; + f.swapper := -1; + GetType(name, type); + f.InitType(type); + ASSERT(ref # invalid, 107); + f.ref := ref; f.name := fname$; f.state := s; f.t := Kernel.Time(); + Stat(f.name, buf, res); + f.len := SHORT(buf.st_size); (* A. V. Shiryaev: OpenBSD *) + res := LinLibc.fseek(ref, 0, LinLibc.SEEK_SET); + END + END; + loc.res := Error(res); + RETURN f + END Old; + + PROCEDURE (d: Directory) Delete* (loc: Files.Locator; name: Files.Name); + VAR res: INTEGER; fname: FullName; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + Append(loc.path, name, "", loc.maxLen, fname); + Delete(fname, loc.path, res) + ELSE res := invalidNameErr + END; + loc.res := Error(res) + END Delete; + + PROCEDURE (d: Directory) Rename* (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN); + VAR res, i: INTEGER; oldname, newname: FullName; f: File; on, nn, tn: ShortName; buf: LinLibc.stat_t; + ok1: BOOLEAN; tName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + Append(loc.path, old, "", loc.maxLen, oldname); Append(loc.path, new, "", loc.maxLen, newname); + Short(oldname, on, ok1); Short(newname, nn, ok1); + Stat(oldname, buf, res); + IF res = ok THEN + f := ThisFile(oldname); + IF (f # NIL) & (f.ref # invalid) THEN res := LinLibc.fclose(f.ref); f.ref := invalid END; + IF Diff(oldname, newname, loc.caseSens) # 0 THEN + CheckDelete(newname, loc.path, ask, res); + IF res = ok THEN + IF LinLibc.rename(on, nn) = 0 THEN + IF f # NIL THEN (* still in use => update file table *) + f.name := newname$ + END + ELSE res := LinLibc_errno() + END + END + ELSE (* destination is same file as source *) + tName := oldname; i := LEN(tName$) - 1; + REPEAT + tName[i] := CHR(ORD(tName[i]) + 1); + Short(tName, tn, ok1); + MoveFile(on, tn, res); + UNTIL (res # fileExistsErr) & (res # alreadyExistsErr) & (res # 87); + IF res = ok THEN + MoveFile(tn, nn, res) + END + END + ELSE res := fileNotFoundErr + END + ELSE res := invalidNameErr + END; + loc.res := Error(res) + END Rename; + + PROCEDURE (d: Directory) SameFile* (loc0: Files.Locator; name0: Files.Name; + loc1: Files.Locator; name1: Files.Name + ): BOOLEAN; + VAR p0, p1: FullName; + BEGIN + ASSERT(loc0 # NIL, 20); ASSERT(loc1 # NIL, 21); + WITH loc0: Locator DO Append(loc0.path, name0, "", loc0.maxLen, p0) END; + WITH loc1: Locator DO Append(loc1.path, name1, "", loc1.maxLen, p1) END; + RETURN Diff(p0, p1, loc0(Locator).caseSens) = 0 + END SameFile; + + PROCEDURE (d: Directory) FileList* (loc: Files.Locator): Files.FileInfo; + VAR diff, res: INTEGER; first, last, info: Files.FileInfo; s: FullName; + ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t; tm: LinLibc.tm; + isDir: BOOLEAN; attr: SET; ok1: BOOLEAN; dName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + first := NIL; last :=NIL; + WITH loc: Locator DO + Short(loc.path, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.stat(fname, buf); (* Shiryaev A. V.: OpenBSD *) + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN + info := first; last := NIL; s := dName; + WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END; + NEW(info); + info.name := dName$; + GetType(info.name, info.type); + info.length := SHORT(buf.st_size); (* A. V. Shiryaev: OpenBSD *) + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + info.modified.year := tm.tm_year + 1900; + info.modified.month := tm.tm_mon + 1; + info.modified.day := tm.tm_mday; + info.modified.hour := tm.tm_hour; + info.modified.minute := tm.tm_min; + info.modified.second := tm.tm_sec + END; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END; + (* check startup directory *) + IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN + GetShadowDir(loc, s); + Short(s, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.stat(fname, buf); (* Shiryaev A. V.: OpenBSD *) + ModeToAttr(buf.st_mode, attr, isDir); + IF ~isDir THEN + info := first; last := NIL; s := dName; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END; + WHILE (info # NIL) & (diff < 0) DO + last := info; info := info.next; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END + END; + IF (info = NIL) OR (diff # 0) THEN + NEW(info); + info.name := dName$; + GetType(info.name, info.type); + info.length := SHORT(buf.st_size); (* A. V. Shiryaev: OpenBSD *) + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + info.modified.year := tm.tm_year + 1900; + info.modified.month := tm.tm_mon + 1; + info.modified.day := tm.tm_mday; + info.modified.hour := tm.tm_hour; + info.modified.minute := tm.tm_min; + info.modified.second := tm.tm_sec + END; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END + END; + loc.res := Error(res) + ELSE loc.res := invalidName + END; + RETURN first + END FileList; + + PROCEDURE (d: Directory) LocList* (loc: Files.Locator): Files.LocInfo; + VAR diff, res: INTEGER; first, last, info: Files.LocInfo; s: FullName; isDir: BOOLEAN; attr: SET; + ss, fname: ShortName; dirp: LinLibc.PtrDIR; dp: LinLibc.PtrDirent; buf: LinLibc.stat_t; + ok1: BOOLEAN; dName: FullName; + BEGIN + ASSERT(loc # NIL, 20); + first := NIL; last :=NIL; + WITH loc: Locator DO + Short(loc.path, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.stat(fname, buf); (* Shiryaev A. V.: OpenBSD *) + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN + info := first; last := NIL; s := dName; + WHILE (info # NIL) & (Diff(info.name, s, loc.caseSens) < 0) DO last := info; info := info.next END; + NEW(info); + info.name := dName$; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END; + (* check startup directory *) + IF (loc.rootLen > 0) & ((res = ok) OR (res = fileNotFoundErr) OR (res = pathNotFoundErr)) THEN + GetShadowDir(loc, s); + Short(s, ss, ok1); + dirp := LinLibc.opendir(ss); + IF dirp # LinLibc.NULL THEN + dp := LinLibc.readdir(dirp); + WHILE dp # NIL DO + Long(dp.d_name$, dName, ok1); + IF ok1 & (dp.d_name # ".") & (dp.d_name # "..") & (LEN(dName$) < LEN(info.name)) THEN + fname := ss + "/" + dp.d_name; + res := LinLibc.stat(fname, buf); (* Shiryaev A. V.: OpenBSD *) + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN + info := first; last := NIL; s := dName; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END; + WHILE (info # NIL) & (diff < 0) DO + last := info; info := info.next; + IF info # NIL THEN diff := Diff(info.name, s, loc.caseSens) END + END; + IF (info = NIL) OR (diff # 0) THEN + NEW(info); + info.name := dName$; + info.attr := attr; + IF last = NIL THEN info.next := first; first := info ELSE info.next := last.next; last.next := info END + END + END + END; + dp := LinLibc.readdir(dirp) + END; + res := LinLibc.closedir(dirp) + ELSE res := LinLibc_errno() + END + END; + loc.res := Error(res) + ELSE loc.res := invalidName + END; + RETURN first + END LocList; + + PROCEDURE (d: Directory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name); + BEGIN + Append("", name, type, LEN(filename), filename) + END GetFileName; + + (** Miscellaneous **) + + PROCEDURE (VAR id: Counter) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := id.obj(File); + IF f.state # closed THEN INC(id.count) END; + RETURN FALSE + END Identified; + + PROCEDURE NofFiles* (): INTEGER; + VAR p: ANYPTR; cnt: Counter; + BEGIN + cnt.typ := SYSTEM.TYP(File); + cnt.count := 0; p := Kernel.ThisFinObj(cnt); + RETURN cnt.count + END NofFiles; + + PROCEDURE GetModDate* (f: Files.File; VAR year, month, day, hour, minute, second: INTEGER); + VAR buf: LinLibc.stat_t; tm: LinLibc.tm; + BEGIN + ASSERT(f IS File, 20); + Stat(f(File).name, buf, res); + IF res = ok THEN + tm := LinLibc.localtime(buf.st_mtime); + IF tm # NIL THEN + year := tm.tm_year + 1900; month := tm.tm_mon + 1; day := tm.tm_mday; + hour := tm.tm_hour; minute := tm.tm_min; second := tm.tm_sec + ELSE + res := -1 + END + END; + IF res # ok THEN year := 0; month := 0; day := 0; hour := 0; minute := 0; second := 0 END + END GetModDate; + + PROCEDURE SetRootDir* (path: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + dir.startup := NewLocator(path); + dir.startup.rootLen := 0; i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i + END SetRootDir; + +(* + PROCEDURE GetName (VAR p: ARRAY OF CHAR; VAR i: INTEGER; OUT name, opt: FullName); + VAR ch, tch: CHAR; j: INTEGER; + BEGIN + j := 0; ch := p[i]; tch := " "; + WHILE ch = " " DO INC(i); ch := p[i] END; + IF (ch = "'") OR (ch = '"') THEN tch := ch; INC(i); ch := p[i] END; + WHILE (ch >= " ") & (ch # tch) DO + name[j] := ch; + IF (ch >= "a") & (ch <= "z") OR (ch >= "à") & (ch <= "ö") OR (ch >= "ø") & (ch <= "þ") THEN ch := CAP(ch) + ELSIF ch = "-" THEN ch := "/" + END; + opt[j] := ch; INC(j); INC(i); ch := p[i] + END; + IF ch > " " THEN INC(i); ch := p[i] END; + WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := p[i] END; + name[j] := 0X; opt[j] := 0X + END GetName; + + PROCEDURE Init; + VAR res, i, slp: INTEGER; path, opt: FullName; attr: SET; p: LinLibc.PtrSTR; str: ARRAY 256 OF CHAR; + buf: LinLibc.stat_t; isDir: BOOLEAN; + BEGIN +(* + TODO: + Instead of using getcwd below to find the local path it would be better to use Kernel.bootinfo.argv[0]. + But this only works if the PATH variable of the shell is not set to hold the BlackBox directory. In that + case all directories in the PATH variable has to be searched for the blackbox executable: + if (argv[0][0] == '/') + s = argv[0] + else { + str = getenv( "PATH" ); len = strlen( str ); + for ( i = 0, s = 0; i < len; i++ ) + if ( str[i] == ':' ) { + str[i] = '\0'; + if ( checkpath( str + s, argv[0] ) ) break; + else s = i + 1; + } + } +*) + wildcard := "*"; NEW(dir); + str := Kernel.cmdLine$; + i := 0; slp := -1; + WHILE (str[i] # " ") & (str[i] # 0X) DO + startupDir[i] := str[i]; + IF str[i] = "/" THEN slp := i END; + INC(i) + END; + startupDir[i] := 0X; + IF slp < 0 THEN + appName := startupDir; + p := NIL; + p := LinLibc.getcwd(p, 0); + startupDir := p$; + LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)); + i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i; + ELSE + i := slp + 1; + WHILE startupDir[i] # 0X DO appName[i - slp - 1] := startupDir[i]; INC(i) END; + startupDir[slp] := 0X; + startupLen := slp; + END; + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; +(* + p := NIL; + p := LinLibc.getcwd(p, 0); + startupDir := p$; LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)); + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; i := 0; + WHILE startupDir[i] # 0X DO INC(i) END; + startupLen := i; + str := Kernel.cmdLine$; +*) +(* + i := 0; + WHILE (str[i] # " ") & (str[i] # 0X) DO appName[i] := str[i]; INC(i) END; + appName[i] := 0X; +*) + i := 0; res := 1; + REPEAT + GetName(str, i, path, opt); + IF opt = "/USE" THEN + GetName(str, i, path, opt); + Stat(path, buf, res); + IF res =ok THEN + ModeToAttr(buf.st_mode, attr, isDir); + IF isDir THEN res := ok ELSE res := invalidName END + END + END + UNTIL (res = 0) OR (str[i] < " "); + IF serverVersion & (res = 0) THEN + i := 0; WHILE path[i] # 0X DO INC(i) END; + IF (path[i-1] = "/") OR (path[i-1] = "\") THEN DEC(i); path[i] := 0X END; + dir.startup := NewLocator(path); + dir.startup.rootLen := SHORT(i) + END; + dir.temp := NewLocator(LinLibc.P_tmpdir); + Files.SetDir(dir) + END Init; +*) + + PROCEDURE Init; + CONST bbServerDir = "BB_PRIMARY_DIR"; bbWorkDir = "BB_SECONDARY_DIR"; + VAR res: INTEGER; attr: SET; p: LinLibc.PtrSTR; + buf: LinLibc.stat_t; isDir, def1: BOOLEAN; + ok1: BOOLEAN; fname: FullName; + BEGIN + InitConv; + + wildcard := "*"; NEW(dir); + + p := LinLibc.getenv(bbServerDir); (* p = NIL -> undefined *) + def1 := FALSE; + IF p # NIL THEN + Long(p$, fname, ok1); + IF ok1 THEN + Stat(fname, buf, res); + IF res = ok THEN + ModeToAttr(buf.st_mode, attr, isDir); + def1 := isDir + END + END; + IF ~def1 THEN Msg("HostFiles: Value of " + bbServerDir + " isn't directory, using cwd") END + END; + IF ~def1 THEN + p := NIL; + p := LinLibc.getcwd(p, 0); + Long(p$, fname, ok1); + IF ~ok1 THEN fname := "." END; + LinLibc.free(SYSTEM.VAL(LinLibc.PtrVoid, p)) + END; + startupDir := fname; startupLen := LEN(startupDir$); + dir.startup := NewLocator(startupDir); + dir.startup.rootLen := 0; + + p := LinLibc.getenv(bbWorkDir); (* p = NIL -> undefined *) + IF def1 & (p # NIL) THEN + Long(p$, fname, ok1); + IF ok1 THEN + Stat(fname, buf, res); + ok1 := res = ok; + IF ok1 THEN + ModeToAttr(buf.st_mode, attr, isDir); + ok1 := isDir + END + END; + IF ~serverVersion THEN + (* - *) + ELSIF ok1 THEN + dir.startup := NewLocator(fname); dir.startup.rootLen := LEN(fname$) + ELSE + Msg("HostFiles: Value of " + bbWorkDir + " isn't directory, server configuration isn't enabled") + END + END; + + dir.temp := NewLocator(LinLibc.P_tmpdir); + Files.SetDir(dir) + END Init; + +BEGIN + Init +CLOSE + CloseConv +END HostFiles. diff --git a/Trurl-based/_OpenBSD_/Lin/Mod/Dl.txt b/Trurl-based/_OpenBSD_/Lin/Mod/Dl.txt new file mode 100644 index 0000000..8213f44 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Mod/Dl.txt @@ -0,0 +1,35 @@ +MODULE LinDl ["libdlobsdwrap.so"]; + + (* + A. V. Shiryaev, 2012.09 + + OpenBSD 5.2 + 32-bit + *) + + IMPORT SYSTEM; + + CONST + NULL* = 0H; + + (* from OpenBSD 5.2 /usr/include/dlfcn.h *) + RTLD_LAZY* = 1; + (* DL_LAZY* = RTLD_LAZY; *) (* compat *) + RTLD_NOW* = 2; + + RTLD_GLOBAL* = 100H; + RTLD_LOCAL* = 000H; + RTLD_TRACE* = 200H; + + TYPE + PtrVoid* = INTEGER; + HANDLE* = PtrVoid; + PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + PROCEDURE [ccall] dlopen* ["__dlopen"] (file: PtrSTR; mode: INTEGER): HANDLE; + PROCEDURE [ccall] dlclose* ["__dlclose"] (handle: HANDLE): INTEGER; + PROCEDURE [ccall] dlsym* ["__dlsym"] (handle: HANDLE; symbol: PtrSTR): HANDLE; + + PROCEDURE [ccall] dlerror* ["__dlerror"] (): PtrSTR; + +END LinDl. diff --git a/Trurl-based/_OpenBSD_/Lin/Mod/Iconv.txt b/Trurl-based/_OpenBSD_/Lin/Mod/Iconv.txt new file mode 100644 index 0000000..e1a1f38 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Mod/Iconv.txt @@ -0,0 +1,22 @@ +MODULE LinIconv ["libiconv.so.6"]; + + IMPORT Libc := LinLibc; + + TYPE + PtrVoid = Libc.PtrVoid; + PtrSTR* = Libc.PtrSTR; + PtrLSTR* = POINTER TO ARRAY [untagged] OF CHAR; + size_t* = Libc.size_t; + + iconv_t* = PtrVoid; + + PROCEDURE [ccall] iconv_open* ["libiconv_open"] (tocode, fromcode: PtrSTR): iconv_t; + PROCEDURE [ccall] iconv_close* ["libiconv_close"] (cd: iconv_t): INTEGER; + + PROCEDURE [ccall] iconv* ["libiconv"] (cd: iconv_t; VAR [nil] inbuf: PtrSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrSTR; VAR outbytesleft: size_t): size_t; + + PROCEDURE [ccall] iconv_encode* ["libiconv"] (cd: iconv_t; VAR [nil] inbuf: PtrLSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrSTR; VAR outbytesleft: size_t): size_t; + + PROCEDURE [ccall] iconv_decode* ["libiconv"] (cd: iconv_t; VAR [nil] inbuf: PtrSTR; VAR inbytesleft: size_t; VAR [nil] outbuf: PtrLSTR; VAR outbytesleft: size_t): size_t; + +END LinIconv. diff --git a/Trurl-based/_OpenBSD_/Lin/Mod/Ioctl.txt b/Trurl-based/_OpenBSD_/Lin/Mod/Ioctl.txt new file mode 100644 index 0000000..e961329 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Mod/Ioctl.txt @@ -0,0 +1,48 @@ +MODULE LinIoctl ["libc.so.66.0"]; + + (* + A. V. Shiryaev, 2012.11 + + OpenBSD 5.2 + 32-bit + *) + + IMPORT Libc := LinLibc; + + CONST + (* /usr/include/sys/ttycom.h *) + TIOCM_LE* = 1; (* line enable *) + TIOCM_DTR* = 2; (* data terminal ready *) + TIOCM_RTS* = 4; (* request to send *) + TIOCM_ST* = 8; (* secondary transmit *) + TIOCM_SR* = 16; (* secondary receive *) + TIOCM_CTS* = 32; (* clear to send *) + TIOCM_CAR* = 64; (* carrier detect *) + TIOCM_RNG* = 128; (* ring *) + TIOCM_DSR* = 256; (* data set ready *) + + FIOCLEX* = 536897025; + FIONCLEX* = 536897026; + FIONREAD* = 1074030207; + FIONBIO* = -2147195266; + FIOASYNC* = -2147195267; + FIOSETOWN* = -2147195268; + FIOGETOWN* = 1074030203; + TIOCMGET* = 1074033770; + TIOCMSET* = -2147191699; + TIOCEXCL* = 536900621; + TIOCNXCL* = 536900622; + TIOCFLUSH* = -2147191792; + TIOCDRAIN* = 536900702; + TIOCOUTQ* = 1074033779; + TIOCSBRK* = 536900731; + TIOCCBRK* = 536900730; + TIOCSDTR* = 536900729; + TIOCCDTR* = 536900728; + TIOCMBIS* = -2147191700; + TIOCMBIC* = -2147191701; + + PROCEDURE [ccall] ioctl0* ["ioctl"] (d: INTEGER; req: INTEGER): INTEGER; + PROCEDURE [ccall] ioctl1* ["ioctl"] (d: INTEGER; req: INTEGER; data: Libc.PtrVoid): INTEGER; + +END LinIoctl. diff --git a/Trurl-based/_OpenBSD_/Lin/Mod/Libc.txt b/Trurl-based/_OpenBSD_/Lin/Mod/Libc.txt new file mode 100644 index 0000000..e8a9294 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Mod/Libc.txt @@ -0,0 +1,785 @@ +MODULE LinLibc ["libc.so.66.0"]; + + (* + A. V. Shiryaev, 2012.09 + + Based on Linux' LinLibc (OpenBUGS Lin/Mod/Libc.odc) + + OpenBSD 5.2 + 32-bit + *) + + IMPORT SYSTEM; + + CONST + NULL* = 0H; + TRUE* = 1; + FALSE* = 0; + + (* file constants *) + SEEK_SET* = 0; + SEEK_CUR* = 1; + SEEK_END* = 2; + NAME_MAX* = 255; (* OpenBSD /usr/include/sys/syslimits.h *) + + (* The value of CLOCKS_PER_SEC is required to be 1 million on all XSI-conformant systems.*) + CLOCKS_PER_SEC* = 100; (* OpenBSD 5.2 /usr/include/time.h CLOCKS_PER_SEC *) + + (* temp directory defined in stdio.h *) + P_tmpdir* = "/tmp"; + + (* signal constants *) (* Fake signal functions. *) + (* OpenBSD 5.2 /usr/include/sys/signal.h *) + SIG_ERR* = -1; (* Error return. *) + SIG_DFL* = 0; (* Default action. *) + SIG_IGN* = 1; (* Ignore signal. *) + SIG_HOLD* = 3; (* Add signal to hold mask. *) (* OpenBSD 5.2 /usr/include/sys/signalvar.h *) + + (* Signals. *) + (* OpenBSD /usr/include/sys/signal.h *) + _NSIG* = 33; (* counting 0 (mask is 1-32) *) + SIGHUP* = 1; (* hangup *) + SIGINT* = 2; (* interrupt *) + SIGQUIT* = 3; (* quit *) + SIGILL* = 4; (* illegal instruction (not reset when caught) *) + SIGTRAP* = 5; (* trace trap (not reset when caught) *) + SIGABRT* = 6; (* abort() *) + SIGFPE* = 8; (* floating point exception *) + SIGKILL* = 9; (* kill (cannot be caught or ignored) *) + SIGBUS* = 10; (* bus error *) + SIGSEGV* = 11; (* segmentation violation *) + SIGSYS* = 12; (* bad argument to system call *) + SIGPIPE* = 13; (* write on a pipe with no one to read it *) + SIGALRM* = 14; (* alarm clock *) + SIGTERM* = 15; (* software termination signal from kill *) + SIGURG* = 16; (* urgent condition on IO channel *) + SIGSTOP* = 17; (* sendable stop signal not from tty *) + SIGTSTP* = 18; (* stop signal from tty *) + SIGCONT* = 19; (* continue a stopped process *) + SIGCHLD* = 20; (* to parent on child stop or exit *) + SIGTTIN* = 21; (* to readers pgrp upon background tty read *) + SIGTTOU* = 22; (* like TTIN for output if (tp->t_local<OSTOP) *) + SIGXCPU* = 24; (* exceeded CPU time limit *) + SIGXFSZ* = 25; (* exceeded file size limit *) + SIGVTALRM* = 26; (* virtual time alarm *) + SIGPROF* = 27; (* profiling time alarm *) + SIGUSR1* = 30; (* user defined signal 1 *) + SIGUSR2* = 31; (* user defined signal 2 *) + SIGWINCH* = 28; (* window size changes *) + SIGTHR* = 32; (* thread library AST *) + + + (* Bits in `sa_flags'. *) + SA_NOCLDSTOP* = {3}; (* = 1 Don't send SIGCHLD when children stop. *) (* OpenBSD *) + SA_NOCLDWAIT* = {5}; (* = 2 Don't create zombie on child death. *) (* OpenBSD *) + SA_SIGINFO* = {6}; (* = 4 Invoke signal-catching function wth three arguments instead of one. *) (* OpenBSD *) + SA_ONSTACK* = {0}; (* = 0x08000000 Use signal stack by using `sa_restorer'. *) (* OpenBSD *) + SA_RESTART* = {1}; (* = 0x10000000 Restart syscall on signal return. *) (* OpenBSD *) + SA_NODEFER* = {4}; (* = 0x40000000 Don't automatically block the signal when its handler is being executed. *) (* OpenBSD *) + SA_RESETHAND* = {2}; (* = 0x80000000 Reset to SIG_DFL on entry to handler. *) (* OpenBSD *) + (* SA_INTERRUPT* = {29}; (* = 0x20000000 Historical no-op. *) *) (* OpenBSD *) + (* Some aliases for the SA_ constants. *) + SA_NOMASK* = SA_NODEFER; + SA_ONESHOT* = SA_RESETHAND; + SA_STACK* = SA_ONSTACK; + + (* code values for siginfo_t.si_code *) + (* OpenBSD /usr/include/sys/siginfo.h *) + FPE_INTDIV* = 1; (* integer divide by zero *) + FPE_INTOVF* = 2; (* integer overflow *) + FPE_FLTDIV* = 3; (* floating point divide by zero *) + FPE_FLTOVF* = 4; (* floating point overflow *) + FPE_FLTUND* = 5; (* floating point underflow *) + FPE_FLTRES* = 6; (* floating point inexact result *) + FPE_FLTINV* = 7; (* invalid floating point operation *) + FPE_FLTSUB* = 8; (* subscript out of range *) + ILL_ILLOPC* = 1; (* illegal opcode *) + ILL_ILLOPN* = 2; (* illegal operand *) + ILL_ILLADR* = 3; (* illegal addressing mode *) + ILL_ILLTRP* = 4; (* illegal trap *) + ILL_PRVOPC* = 5; (* privileged opcode *) + ILL_PRVREG* = 6; (* privileged register *) + ILL_COPROC* = 7; (* co-processor *) + ILL_BADSTK* = 8; (* bad stack *) + SEGV_MAPERR* = 1; (* address not mapped to object *) + SEGV_ACCERR* = 2; (* invalid permissions *) + BUS_ADRALN* = 1; (* invalid address alignment *) + BUS_ADRERR* = 2; (* non-existent physical address *) + BUS_OBJERR* = 3; (* object specific hardware error *) + + + (* possible error constants for errno *) + (* OpenBSD /usr/include/sys/errno.h *) + EPERM* = 1; (* Operation not permitted *) + ENOENT* = 2; (* No such file or directory *) + ESRCH* = 3; (* No such process *) + EINTR* = 4; (* Interrupted system call *) + EIO* = 5; (* Input/output error *) + ENXIO* = 6; (* Device not configured *) + E2BIG* = 7; (* Argument list too long *) + ENOEXEC* = 8; (* Exec format error *) + EBADF* = 9; (* Bad file descriptor *) + ECHILD* = 10; (* No child processes *) + EDEADLK* = 11; (* Resource deadlock avoided *) + ENOMEM* = 12; (* Cannot allocate memory *) + EACCES* = 13; (* Permission denied *) + EFAULT* = 14; (* Bad address *) + EBUSY* = 16; (* Device busy *) + EEXIST* = 17; (* File exists *) + EXDEV* = 18; (* Cross-device link *) + ENODEV* = 19; (* Operation not supported by device *) + ENOTDIR* = 20; (* Not a directory *) + EISDIR* = 21; (* Is a directory *) + EINVAL* = 22; (* Invalid argument *) + ENFILE* = 23; (* Too many open files in system *) + EMFILE* = 24; (* Too many open files *) + ENOTTY* = 25; (* Inappropriate ioctl for device *) + ETXTBSY* = 26; (* Text file busy *) + EFBIG* = 27; (* File too large *) + ENOSPC* = 28; (* No space left on device *) + ESPIPE* = 29; (* Illegal seek *) + EROFS* = 30; (* Read-only file system *) + EMLINK* = 31; (* Too many links *) + EPIPE* = 32; (* Broken pipe *) + EDOM* = 33; (* Numerical argument out of domain *) + ERANGE* = 34; (* Result too large *) + EAGAIN* = 35; (* Resource temporarily unavailable *) + EWOULDBLOCK* = EAGAIN; (* Operation would block *) + EINPROGRESS* = 36; (* Operation now in progress *) + EALREADY* = 37; (* Operation already in progress *) + ENOTSOCK* = 38; (* Socket operation on non-socket *) + EDESTADDRREQ* = 39; (* Destination address required *) + EMSGSIZE* = 40; (* Message too long *) + EPROTOTYPE* = 41; (* Protocol wrong type for socket *) + ENOPROTOOPT* = 42; (* Protocol not available *) + EPROTONOSUPPORT* = 43; (* Protocol not supported *) + EOPNOTSUPP* = 45; (* Operation not supported *) + EAFNOSUPPORT* = 47; (* Address family not supported by protocol family *) + EADDRINUSE* = 48; (* Address already in use *) + EADDRNOTAVAIL* = 49; (* Can't assign requested address *) + ENETDOWN* = 50; (* Network is down *) + ENETUNREACH* = 51; (* Network is unreachable *) + ENETRESET* = 52; (* Network dropped connection on reset *) + ECONNABORTED* = 53; (* Software caused connection abort *) + ECONNRESET* = 54; (* Connection reset by peer *) + ENOBUFS* = 55; (* No buffer space available *) + EISCONN* = 56; (* Socket is already connected *) + ENOTCONN* = 57; (* Socket is not connected *) + ETIMEDOUT* = 60; (* Operation timed out *) + ECONNREFUSED* = 61; (* Connection refused *) + ELOOP* = 62; (* Too many levels of symbolic links *) + ENAMETOOLONG* = 63; (* File name too long *) + ENOTEMPTY* = 66; (* Directory not empty *) + EDQUOT* = 69; (* Disk quota exceeded *) + ESTALE* = 70; (* Stale NFS file handle *) + ENOLCK* = 77; (* No locks available *) + ENOSYS* = 78; (* Function not implemented *) + EILSEQ* = 84; (* Illegal byte sequence *) + EIDRM* = 89; (* Identifier removed *) + ENOMSG* = 90; (* No message of desired type *) + ENOTSUP* = 91; (* Not supported *) + + + (* OpenBSD 5.2 /usr/include/i386/setjmp.h *) + _JBLEN = 10; + + (* OpenBSD 5.2 /usr/include/sys/mman.h *) + PROT_NONE* = {}; (* no permission *) + PROT_READ* = {0}; (* pages can be read *) + PROT_WRITE* = {1}; (* pages can be written *) + PROT_EXEC* = {2}; (* pages can be executed *) + + (* OpenBSD 5.2 /usr/include/sys/mman.h *) + MAP_FILE* = {}; (* map from file (default) *) + MAP_ANON* = {12}; (* allocated from memory, swap space *) + MAP_FIXED* = {4}; (* map addr must be exactly as requested *) + MAP_HASSEMAPHORE* = {9}; (* region may contain semaphores *) + MAP_INHERIT* = {7}; (* region is retained after exec *) + MAP_PRIVATE* = {1}; (* changes are private *) + MAP_SHARED* = {0}; (* share changes *) + MAP_TRYFIXED* = {10}; (* attempt hint address, even within heap *) + MAP_COPY* = {2}; (* "copy" region at mmap time *) + + MAP_FAILED* = -1; + + (* OpenBSD 5.2 /usr/include/i386/param.h *) + PAGE_SHIFT* = 12; + PAGE_SIZE* = 4096; (* LSL(1, PAGE_SHIFT) *) + PAGE_MASK* = PAGE_SIZE - 1; + + (* OpenBSD 5.2: /usr/include/fcntl.h *) + O_RDONLY* = {}; + O_WRONLY* = {0}; + O_RDWR* = {1}; + O_ACCMODE* = {0,1}; + + O_NONBLOCK* = {2}; (* Do not block on open or for data to become available *) + O_APPEND* = {3}; (* Append on each write *) + O_CREAT* = {9}; (* Create file if it does not exist *) + O_TRUNC* = {10}; (* Truncate size to 0 *) + O_EXCL* = {11}; (* Error if create and file exists *) + O_SYNC* = {7}; (* Perform synchronous I/O operations *) + O_SHLOCK* = {4}; (* Atomically obtain a shared lock *) + O_EXLOCK* = {5}; (* Atomically obtain an exclusive lock *) + O_NOFOLLOW* = {8}; (* If last path element is a symlink, don't follow it *) + O_CLOEXEC* = {16}; (* Set FD_CLOEXEC on the new file descriptor *) + O_DIRECTORY* = {17}; (* Error if path does not name a directory *) + + (* OpenBSD 5.2 /usr/include/unistd.h *) + _SC_ARG_MAX* = 1; + _SC_CHILD_MAX* = 2; + _SC_CLK_TCK* = 3; + _SC_NGROUPS_MAX* = 4; + _SC_OPEN_MAX* = 5; + _SC_JOB_CONTROL* = 6; + _SC_SAVED_IDS* = 7; + _SC_VERSION* = 8; + _SC_BC_BASE_MAX* = 9; + _SC_BC_DIM_MAX* = 10; + _SC_BC_SCALE_MAX* = 11; + _SC_BC_STRING_MAX* = 12; + _SC_COLL_WEIGHTS_MAX* = 13; + _SC_EXPR_NEST_MAX* = 14; + _SC_LINE_MAX* = 15; + _SC_RE_DUP_MAX* = 16; + _SC_2_VERSION* = 17; + _SC_2_C_BIND* = 18; + _SC_2_C_DEV* = 19; + _SC_2_CHAR_TERM* = 20; + _SC_2_FORT_DEV* = 21; + _SC_2_FORT_RUN* = 22; + _SC_2_LOCALEDEF* = 23; + _SC_2_SW_DEV* = 24; + _SC_2_UPE* = 25; + _SC_STREAM_MAX* = 26; + _SC_TZNAME_MAX* = 27; + _SC_PAGESIZE* = 28; + _SC_PAGE_SIZE* = _SC_PAGESIZE; (* 1170 compatibility *) + _SC_FSYNC* = 29; + _SC_XOPEN_SHM* = 30; + _SC_SEM_NSEMS_MAX* = 31; + _SC_SEM_VALUE_MAX* = 32; + _SC_HOST_NAME_MAX* = 33; + _SC_MONOTONIC_CLOCK* = 34; + _SC_2_PBS* = 35; + _SC_2_PBS_ACCOUNTING* = 36; + _SC_2_PBS_CHECKPOINT* = 37; + _SC_2_PBS_LOCATE* = 38; + _SC_2_PBS_MESSAGE* = 39; + _SC_2_PBS_TRACK* = 40; + _SC_ADVISORY_INFO* = 41; + _SC_AIO_LISTIO_MAX* = 42; + _SC_AIO_MAX* = 43; + _SC_AIO_PRIO_DELTA_MAX* = 44; + _SC_ASYNCHRONOUS_IO* = 45; + _SC_ATEXIT_MAX* = 46; + _SC_BARRIERS* = 47; + _SC_CLOCK_SELECTION* = 48; + _SC_CPUTIME* = 49; + _SC_DELAYTIMER_MAX* = 50; + _SC_IOV_MAX* = 51; + _SC_IPV6* = 52; + _SC_MAPPED_FILES* = 53; + _SC_MEMLOCK* = 54; + _SC_MEMLOCK_RANGE* = 55; + _SC_MEMORY_PROTECTION* = 56; + _SC_MESSAGE_PASSING* = 57; + _SC_MQ_OPEN_MAX* = 58; + _SC_MQ_PRIO_MAX* = 59; + _SC_PRIORITIZED_IO* = 60; + _SC_PRIORITY_SCHEDULING* = 61; + _SC_RAW_SOCKETS* = 62; + _SC_READER_WRITER_LOCKS* = 63; + _SC_REALTIME_SIGNALS* = 64; + _SC_REGEXP* = 65; + _SC_RTSIG_MAX* = 66; + _SC_SEMAPHORES* = 67; + _SC_SHARED_MEMORY_OBJECTS* = 68; + _SC_SHELL* = 69; + _SC_SIGQUEUE_MAX* = 70; + _SC_SPAWN* = 71; + _SC_SPIN_LOCKS* = 72; + _SC_SPORADIC_SERVER* = 73; + _SC_SS_REPL_MAX* = 74; + _SC_SYNCHRONIZED_IO* = 75; + _SC_SYMLOOP_MAX* = 76; + _SC_THREAD_ATTR_STACKADDR* = 77; + _SC_THREAD_ATTR_STACKSIZE* = 78; + _SC_THREAD_CPUTIME* = 79; + _SC_THREAD_DESTRUCTOR_ITERATIONS* = 80; + _SC_THREAD_KEYS_MAX* = 81; + _SC_THREAD_PRIO_INHERIT* = 82; + _SC_THREAD_PRIO_PROTECT* = 83; + _SC_THREAD_PRIORITY_SCHEDULING* = 84; + _SC_THREAD_PROCESS_SHARED* = 85; + _SC_THREAD_ROBUST_PRIO_INHERIT* = 86; + _SC_THREAD_ROBUST_PRIO_PROTECT* = 87; + _SC_THREAD_SPORADIC_SERVER* = 88; + _SC_THREAD_STACK_MIN* = 89; + _SC_THREAD_THREADS_MAX* = 90; + _SC_THREADS* = 91; + _SC_TIMEOUTS* = 92; + _SC_TIMER_MAX* = 93; + _SC_TIMERS* = 94; + _SC_TRACE* = 95; + _SC_TRACE_EVENT_FILTER* = 96; + _SC_TRACE_EVENT_NAME_MAX* = 97; + _SC_TRACE_INHERIT* = 98; + _SC_TRACE_LOG* = 99; + _SC_GETGR_R_SIZE_MAX* = 100; + _SC_GETPW_R_SIZE_MAX* = 101; + _SC_LOGIN_NAME_MAX* = 102; + _SC_THREAD_SAFE_FUNCTIONS* = 103; + _SC_TRACE_NAME_MAX* = 104; + _SC_TRACE_SYS_MAX* = 105; + _SC_TRACE_USER_EVENT_MAX* = 106; + _SC_TTY_NAME_MAX* = 107; + _SC_TYPED_MEMORY_OBJECTS* = 108; + _SC_V6_ILP32_OFF32* = 109; + _SC_V6_ILP32_OFFBIG* = 110; + _SC_V6_LP64_OFF64* = 111; + _SC_V6_LPBIG_OFFBIG* = 112; + _SC_V7_ILP32_OFF32* = 113; + _SC_V7_ILP32_OFFBIG* = 114; + _SC_V7_LP64_OFF64* = 115; + _SC_V7_LPBIG_OFFBIG* = 116; + _SC_XOPEN_CRYPT* = 117; + _SC_XOPEN_ENH_I18N* = 118; + _SC_XOPEN_LEGACY* = 119; + _SC_XOPEN_REALTIME* = 120; + _SC_XOPEN_REALTIME_THREADS* = 121; + _SC_XOPEN_STREAMS* = 122; + _SC_XOPEN_UNIX* = 123; + _SC_XOPEN_UUCP* = 124; + _SC_XOPEN_VERSION* = 125; + _SC_PHYS_PAGES* = 500; + _SC_AVPHYS_PAGES* = 501; + _SC_NPROCESSORS_CONF* = 502; + _SC_NPROCESSORS_ONLN* = 503; + + + (* OpenBSD 5.2 /usr/include/sys/mman.h *) + POSIX_MADV_NORMAL* = 0; (* no further special treatment *) + POSIX_MADV_RANDOM* = 1; (* expect random page references *) + POSIX_MADV_SEQUENTIAL* = 2; (* expect sequential page references *) + POSIX_MADV_WILLNEED* = 3; (* will need these pages *) + POSIX_MADV_DONTNEED* = 4; (* don't need these pages *) + MADV_SPACEAVAIL* = 5; (* insure that resources are reserved *) + MADV_FREE* = 6; (* pages are empty, free them *) + + MADV_NORMAL* = POSIX_MADV_NORMAL; + MADV_RANDOM* = POSIX_MADV_RANDOM; + MADV_SEQUENTIAL* = POSIX_MADV_SEQUENTIAL; + MADV_WILLNEED* = POSIX_MADV_WILLNEED; + MADV_DONTNEED* = POSIX_MADV_DONTNEED; + + (* OpenBSD 5.2 /usr/include/sys/signal.h *) + MINSIGSTKSZ* = 8192; (* minimum allowable stack *) + SIGSTKSZ* = MINSIGSTKSZ + 32768; (* recommended stack size *) + + (* OpenBSD 5.2 /usr/include/sys/signal.h *) + SIG_BLOCK* = 1; (* block specified signal set *) + SIG_UNBLOCK* = 2; (* unblock specified signal set *) + SIG_SETMASK* = 3; (* set specified signal set *) + + TYPE + (* OpenBSD OK *) + __ftw_func_t* = PROCEDURE (fileName: PtrSTR; VAR [nil] stat: stat_t; flag: INTEGER): INTEGER; (* OpenBSD 5.2: OK *) + PtrVoid* = INTEGER; + PtrSTR* = POINTER TO ARRAY [untagged] OF SHORTCHAR; + (* PtrWSTR* = POINTER TO ARRAY [untagged] OF CHAR; *) + PtrInt* = INTEGER; + StrArray* = POINTER TO ARRAY [untagged] OF PtrSTR; + PtrFILE* = INTEGER; + PtrDIR* = INTEGER; + PtrProc* = INTEGER; + clock_t* = INTEGER; (* OpenBSD 5.2 /usr/include/i386/_types.h: 32-bit *) + + (* jmp_buf* = ARRAY [untagged] 6 OF INTEGER; (* bx, si, di, bp, sp, pc *) *) + jmp_buf* = ARRAY [untagged] _JBLEN OF INTEGER; (* OpenBSD 5.2 *) + + mode_t* = SET; (* OpenBSD 5.2: 32-bit *) + off_t* = LONGINT; (* OpenBSD 5.2: 64-bit *) + + SelectorFunc* = PROCEDURE (dirent: Dirent): INTEGER; (* OpenBSD 5.2: OK *) + CmpFunc* = PROCEDURE (VAR [nil] dirent1, dirent2: PtrDirent): INTEGER; (* OpenBSD 5.2: OK *) + + size_t* = INTEGER; (* should be unsigned int *) (* OpenBSD 5.2: /usr/include/i386/_types.h: 32-bit *) + ssize_t* = INTEGER; (* signed int *) (* OpenBSD 5.2: /usr/include/i386/_types.h: 32-bit *) + + sigjmp_buf* = RECORD [untagged] (* OpenBSD 5.2 *) + buf*: jmp_buf; + + (* mask_was_saved*: INTEGER; + saved_mask*: sigset_t; *) (* OpenBSD *) + + xxx: INTEGER; + END; + + PtrDirent* = POINTER TO Dirent; + PtrDirentArray* = POINTER TO ARRAY [untagged] OF Dirent; + + Dirent* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/dirent.h *) + (* + d_ino*: INTEGER; (* inode number *) + d_off*: off_t; (* offset to this dirent *) + d_reclen*: SHORTINT; (* length of this d_name *) + d_type*: BYTE; + d_name*: ARRAY[untagged] NAME_MAX+1 OF SHORTCHAR; (* file name (null-terminated) *) + *) + + d_fileno*: INTEGER; + d_reclen*: SHORTINT; + d_type*: BYTE; + d_namlen*: BYTE; + d_name*: ARRAY [untagged] NAME_MAX + 1 (* 256 *) OF SHORTCHAR; + END; + + pid_t* = INTEGER; (* OpenBSD 5.2: 32-bit *) + uid_t* = INTEGER; (* OpenBSD 5.2: 32-bit *) + + sigval_t* = INTEGER; (* OpenBSD: 32-bit (union sigval) *) + + siginfo_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/siginfo.h *) + si_signo*: INTEGER; (* Signal number *) (* OpenBSD: 32-bit *) + si_code*: INTEGER; (* Signal code *) (* OpenBSD: 32-bit *) + si_errno*: INTEGER; (* An errno value *) (* OpenBSD: 32-bit *) + + (* OpenBSD 5.2: 29 * 4 B below *) + + si_pid*: pid_t; (* Sending process ID *) + si_uid*: uid_t; (* Real user ID of sending process *) + si_status*: INTEGER; (* Exit value or signal *) (* OpenBSD 5.2: 32-bit *) + + (* si_utime*: clock_t; (* User time consumed *) *) (* OpenBSD: XXX *) + si_stime*: clock_t; (* System time consumed *) + (* si_value*: sigval_t; (* Signal value *) *) (* OpenBSD: XXX *) + (* si_int*: INTEGER; (* POSIX.1b signal *) *) (* OpenBSD: XXX *) + (* si_ptr*: PtrVoid; (* POSIX.1b signal *) *) (* OpenBSD: XXX *) + (* si_addr*: PtrVoid; (* Memory location which caused fault *) *) (* OpenBSD: XXX *) + (* si_band*: INTEGER; (* Band event *) *) (* OpenBSD: XXX *) + (* si_fd*: INTEGER; (* File descriptor *) *) (* OpenBSD: XXX *) + + xxx: ARRAY [untagged] 25 OF INTEGER; (* OpenBSD *) + END; + Ptrsiginfo_t* = POINTER TO siginfo_t; + + (* sigset_t* = ARRAY [untagged] 128 OF BYTE; *) + (* OpenBSD 5.2 /usr/include/sys/signal.h *) + (* sigset_t* = ARRAY [untagged] 4 OF BYTE; *) + sigset_t* = SET; + + Ptrsigset_t* = INTEGER; + sigaction_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/signal.h *) + sa_sigaction*: PROCEDURE [ccall] (sig: INTEGER; siginfo: Ptrsiginfo_t; ptr: Ptrucontext_t); (* union with sa_handler*: PtrProc;*) + sa_mask*: sigset_t; + sa_flags*: SET; + (* sa_restorer*: LONGINT; *) (* OpenBSD *) + END; + + stack_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/signal.h *) + ss_sp*: PtrVoid; + ss_size*: size_t; (* OpenBSD *) + ss_flags*: INTEGER; (* OpenBSD *) + END; + + dev_t* = INTEGER; (* OpenBSD: 32-bit *) + gid_t* = INTEGER; (* OpenBSD: 32-bit *) + + stat_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/sys/stat.h *) + st_dev*: dev_t; (* device *) (* OpenBSD: 32-bit *) + (* __pad1: SHORTINT; *) (* OpenBSD *) + st_ino*: INTEGER; (* 64? inode *) (* OpenBSD: 32-bit *) + st_mode*: mode_t; (* protection *) (* OpenBSD: 32-bit *) + st_nlink*: INTEGER; (* number of hard links *) (* OpenBSD: 32-bit *) + st_uid*: uid_t; (* user ID of owner *) (* OpenBSD: 32-bit *) + st_gid*: gid_t; (* group ID of owner *) (* OpenBSD: 32-bit *) + st_rdev*: dev_t; (* device type (if inode device) *) (* OpenBSD: 32-bit *) + st_lspare0*: INTEGER; (* OpenBSD *) + (* __pad2: SHORTINT; *) (* OpenBSD *) + + (* OpenBSD *) + st_atime*: time_t; + st_atimensec*: INTEGER; + st_mtime*: time_t; + st_mtimensec*: INTEGER; + st_ctime*: time_t; + st_ctimensec*: INTEGER; + + st_size*: off_t; (* 64? total size, in bytes *) (* OpenBSD *) + st_blocks*: LONGINT; (* OpenBSD: 64-bit *) + st_blksize*: INTEGER; (* blocksize for filesystem I/O *) + (* st_blocks*: INTEGER; (* 64? number of blocks allocated *) *) (* OpenBSD *) + st_flags*: INTEGER; (* OpenBSD: 32-bit *) + st_gen*: INTEGER; (* OpenBSD: 32-bit *) + st_lspare1*: INTEGER; (* OpenBSD: 32-bit *) + + (* OpenBSD + st_atime*: INTEGER; (* time of last access *) + __unused1: INTEGER; + st_mtime*: INTEGER; (* time of last modification *) + __unused2: INTEGER; + st_ctime*: INTEGER; (* time of last change *) + __unused3: INTEGER; + __unused4: INTEGER; + __unused5: INTEGER; + *) + + (* OpenBSD *) + __st_birthtime*: time_t; + __st_birthtimensec*: INTEGER; + st_qspare*: ARRAY [untagged] 2 OF LONGINT; + END; + + (* OpenBSD + fpreg* = RECORD [untagged] + significand*: ARRAY [untagged] 4 OF CHAR; + exponent*: CHAR; + END; + *) + + (* OpenBSD *) + (* + fpstate* = RECORD [untagged] + cw*: INTEGER; (* unsigned long int *) + sw*: INTEGER; (* unsigned long int *) + tag*: INTEGER; (* unsigned long int *) + ipoff*: INTEGER; (* unsigned long int *) + cssel*: INTEGER; (* unsigned long int *) + dataoff*: INTEGER; (* unsigned long int *) + datasel*: INTEGER; (* unsigned long int *) + _st: ARRAY [untagged] 8 OF fpreg; + status*: INTEGER; (* unsigned long int *) + END; + *) + envxmm* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *) + (*0*) + en_cw*: SHORTINT; (* FPU Control Word *) + en_sw*: SHORTINT; (* FPU Status Word *) + en_tw*: BYTE; (* FPU Tag Word (abridged) *) + en_rsvd0*: BYTE; + en_opcode*: SHORTINT; (* FPU Opcode *) + en_fip*: INTEGER; (* FPU Instruction Pointer *) + en_fcs*: SHORTINT; (* FPU IP selector *) + en_rsvd1*: SHORTINT; + (*16*) + en_foo*: INTEGER; (* FPU Data pointer *) + en_fos*: SHORTINT; (* FPU Data pointer selector *) + en_rsvd2*: SHORTINT; + en_mxcsr*: INTEGER; (* MXCSR Register State *) + en_mxcsr_mask*: INTEGER; (* Mask for valid MXCSR bits (may be 0) *) + END; + (* FPU regsters in the extended save format. *) + fpaccxmm* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *) + fp_bytes*: ARRAY [untagged] 10 OF BYTE; + fp_rsvd*: ARRAY [untagged] 6 OF BYTE; + END; + (* SSE/SSE2 registers. *) + xmmreg* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h *) + sse_bytes*: ARRAY [untagged] 16 OF BYTE; + END; + fpstate* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/npx.h savefpu.savexmm *) + sv_env*: envxmm; (* control/status context *) + sv_ac*: ARRAY [untagged] 8 OF fpaccxmm; (* ST/MM regs *) + sv_xmmregs*: ARRAY [untagged] 8 OF xmmreg; (* XMM regs *) + sv_rsvd*: ARRAY [untagged] 16 * 14 OF BYTE; + (* 512-bytes --- end of hardware portion of save area *) + sv_ex_sw*: INTEGER; (* saved SW from last exception *) + sv_ex_tw*: INTEGER; (* saved TW from last exception *) + END; + + (* OpenBSD + gregset_t* = ARRAY [untagged] 19 OF INTEGER; + *) + fpregset_t* = POINTER TO fpstate; + + (* OpenBSD + mcontext_t* = RECORD [untagged] + gregs*: gregset_t; + fpregs*: fpregset_t; + oldmask*: INTEGER; (* unsigned long int *) + cr2*: INTEGER; (* unsigned long int *) + END; + *) + + Ptrucontext_t* = POINTER TO ucontext_t; + ucontext_t* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/i386/signal.h struct sigcontext *) + (* + uc_flags*: INTEGER; (* unsigned long int *) + uc_link*: Ptrucontext_t; + uc_stack*: stack_t; + uc_mcontext*: mcontext_t; + uc_sigmask: sigset_t; + __fpregs_mem*: fpstate; + *) + + sc_gs*: INTEGER; + sc_fs*: INTEGER; + sc_es*: INTEGER; + sc_ds*: INTEGER; + sc_edi*: INTEGER; + sc_esi*: INTEGER; + sc_ebp*: INTEGER; + sc_ebx*: INTEGER; + sc_edx*: INTEGER; + sc_ecx*: INTEGER; + sc_eax*: INTEGER; + (* XXX *) + sc_eip*: INTEGER; + sc_cs*: INTEGER; + sc_eflags*: INTEGER; + sc_esp*: INTEGER; + sc_ss*: INTEGER; + + sc_onstack*: INTEGER; (* sigstack state to restore *) + sc_mask*: INTEGER; (* signal mask to restore *) + sc_trapno*: INTEGER; (* XXX should be above *) + sc_err*: INTEGER; + + sc_fpstate*: fpregset_t; (* POINTER TO savefpu *) + END; + + (* Times and Dates *) + + tm* = POINTER TO tmDesc; + tmDesc* = RECORD [untagged] (* OpenBSD 5.2 /usr/include/time.h *) + tm_sec*: INTEGER; (* seconds *) + tm_min*: INTEGER; (* minutes *) + tm_hour*: INTEGER; (* hours *) + tm_mday*: INTEGER; (* day of the month *) + tm_mon*: INTEGER; (* month *) + tm_year*: INTEGER; (* year *) + tm_wday*: INTEGER; (* day of the week *) + tm_yday*: INTEGER; (* day in the year *) + tm_isdst*: INTEGER; (* daylight saving time *) + + tm_gmtoff*: INTEGER; (* OpenBSD *) + tm_zone*: PtrSTR; (* OpenBSD *) + END; + + time_t* = INTEGER; (* OpenBSD 5.2 /usr/include/i386/_types.h: 32-bit *) + + FILE = ARRAY [untagged] 88 OF BYTE; (* OpenBSD 5.2 /usr/include/stdio.h *) + + wchar_t* = INTEGER; (* OpenBSD 5.2: 32-bit *) + PtrWSTR* = POINTER TO ARRAY [untagged] OF wchar_t; + + (* OpenBSD 5.2 *) + sigaltstack_t* = RECORD [untagged] + ss_sp*: PtrVoid; + ss_size*: size_t; + ss_flags*: INTEGER; + END; + + VAR + (* timezone*: INTEGER; (* seconds from GMT *) *) (* OpenBSD: not present *) + (* stdin*, stdout*, stderr* : PtrFILE; (* OpenBSD: not present *) *) + + (* OpenBSD: stdin, stdout, stderr *) + __sF*: ARRAY [untagged] 3 OF FILE; (* OpenBSD 5.2 /usr/include/stdio.h *) + (* + stdin = SYSTEM.ADR(__sF[0]) + stdout = SYSTEM.ADR(__sF[1]) + stderr = SYSTEM.ADR(__sF[2]) + *) + + PROCEDURE [ccall] calloc* (nmemb, size: size_t): PtrVoid; + PROCEDURE [ccall] clock* (): clock_t; + + PROCEDURE [ccall] closedir* (dir: PtrDIR): INTEGER; + + PROCEDURE [ccall] chmod* (path: PtrSTR; mode: mode_t); + PROCEDURE [ccall] exit* (status: INTEGER); + + PROCEDURE [ccall] fclose* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fflush* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fopen* (filename, mode: PtrSTR): PtrFILE; + PROCEDURE [ccall] feof* (fp: PtrFILE): INTEGER; + PROCEDURE [ccall] fread* (ptr: PtrVoid; size, nmemb: size_t; stream: PtrFILE): size_t; + PROCEDURE [ccall] fseek* (stream: PtrFILE; offset, origin: INTEGER): INTEGER; + PROCEDURE [ccall] free* (p: PtrVoid); + + PROCEDURE [ccall] ftell* (stream: PtrFILE): (* LONGINT; *) INTEGER; (* OpenBSD 5.2 *) + + PROCEDURE [ccall] ftw* (filename: PtrSTR; func: __ftw_func_t; maxfds: INTEGER): INTEGER; + PROCEDURE [ccall] fwrite* (ptr: PtrVoid; size, nmemb: size_t; stream: PtrFILE): size_t; + PROCEDURE [ccall] getcwd* (buf: PtrSTR; size: size_t): PtrSTR; + + (* PROCEDURE [ccall] getcontext* (ucontext_t: Ptrucontext_t): INTEGER; *) (* OpenBSD *) + + (* PROCEDURE [ccall] gets* (s: PtrSTR); *) + PROCEDURE [ccall] gets* (s: PtrSTR): PtrSTR; (* OpenBSD 5.2 *) + + PROCEDURE [ccall] fgets* (s: PtrSTR; n: INTEGER; fp: PtrFILE): PtrSTR; + PROCEDURE [ccall] gmtime* (VAR timep: time_t): tm; + PROCEDURE [ccall] kill* (pid: pid_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] localtime* (VAR timep: time_t): tm; + PROCEDURE [ccall] malloc* (size: size_t): PtrVoid; + PROCEDURE [ccall] mkdir* (path: PtrSTR; mode: mode_t): INTEGER; + PROCEDURE [ccall] mktime* (timeptr: tm): time_t; + PROCEDURE [ccall] opendir* (filename: PtrSTR): PtrDIR; + PROCEDURE [ccall] printf* (s: PtrSTR): INTEGER; + PROCEDURE [ccall] readdir* (dir: PtrDIR): PtrDirent; + PROCEDURE [ccall] remove* (path: PtrSTR): INTEGER; + PROCEDURE [ccall] rename* (from, to: PtrSTR): INTEGER; + PROCEDURE [ccall] scandir* (dir: PtrDIR; namelist: PtrDirentArray; selector: SelectorFunc; cmp: CmpFunc): INTEGER; + + (* PROCEDURE [ccall] setcontext* (ucontext_t: Ptrucontext_t): INTEGER; *) (* OpenBSD *) + + PROCEDURE [ccall] setjmp* (VAR env: jmp_buf): INTEGER; + PROCEDURE [ccall] sigaction* (sig_num: INTEGER; VAR [nil] act: sigaction_t; VAR [nil] oldact: sigaction_t): INTEGER; + PROCEDURE [ccall] sigaddset* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] sigdelset* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] sigemptyset* (set: Ptrsigset_t): INTEGER; + PROCEDURE [ccall] sigfillset* (set: Ptrsigset_t): INTEGER; + PROCEDURE [ccall] sigismemeber* (set: Ptrsigset_t; sig: INTEGER): INTEGER; + PROCEDURE [ccall] siglongjmp* (VAR env: sigjmp_buf; val: INTEGER); + + PROCEDURE [ccall] signal* (sig_num: INTEGER; sighandler: PtrProc): PtrProc; + (* PROCEDURE [ccall] sigsetjmp* ["__sigsetjmp"] (VAR env: sigjmp_buf; savemask: INTEGER): INTEGER; *) + PROCEDURE [ccall] sigsetjmp* (VAR env: sigjmp_buf; savemask: INTEGER): INTEGER; (* OpenBSD *) + + (* OpenBSD *) + PROCEDURE [ccall] stat* (filename: PtrSTR; VAR buf: stat_t): INTEGER; (* stat is a macro and expands to __xstat(3, filename, buf) *) +(* OpenBSD: __xstat not present + PROCEDURE [ccall] __xstat* (version: INTEGER; filename: PtrSTR; VAR buf: stat_t): INTEGER; +*) + + PROCEDURE [ccall] strftime* (s: PtrSTR; max: size_t; format: PtrSTR; ptm: tm): size_t; + PROCEDURE [ccall] time* (VAR [nil] t: time_t): time_t; + + (* PROCEDURE [ccall] __errno_location*(): INTEGER; *) + PROCEDURE [ccall] __errno_location* ["__errno"] (): INTEGER; (* OpenBSD *) + + PROCEDURE [ccall] open* (path: PtrSTR; flags: SET; mode: mode_t): INTEGER; + PROCEDURE [ccall] close* (d: INTEGER): INTEGER; + PROCEDURE [ccall] read* (d: INTEGER; buf: PtrVoid; nbytes: size_t): ssize_t; + PROCEDURE [ccall] write* (d: INTEGER; buf: PtrVoid; nBytes: size_t): ssize_t; + + (* OpenBSD *) + PROCEDURE [ccall] mprotect* (addr: PtrVoid; len: size_t; prot: SET): INTEGER; + + (* OpenBSD 5.2 *) + PROCEDURE [ccall] madvise* (addr: PtrVoid; len: size_t; behav: INTEGER): INTEGER; + + PROCEDURE [ccall] mmap* (addr: PtrVoid; len: size_t; prot: SET; flags: SET; fd: INTEGER; offset: off_t): PtrVoid; + PROCEDURE [ccall] munmap* (addr: PtrVoid; len: size_t): INTEGER; + + PROCEDURE [ccall] getenv* (name: PtrSTR): PtrSTR; + + (* OpenBSD 5.2: Ok *) + PROCEDURE [ccall] wctomb* (s: PtrSTR; wchar: wchar_t): INTEGER; + PROCEDURE [ccall] wcstombs* (s: PtrSTR; pwcs: PtrWSTR; n: size_t): size_t; + PROCEDURE [ccall] mbtowc* (pwc: PtrWSTR; s: PtrSTR; n: size_t): INTEGER; + PROCEDURE [ccall] mbstowcs* (pwcs: PtrWSTR; s: PtrSTR; n: size_t): size_t; + + (* OpenBSD 5.2 *) + PROCEDURE [ccall] sysconf* (name: INTEGER): INTEGER; + + PROCEDURE [ccall] sigaltstack* (VAR [nil] ss: sigaltstack_t; VAR [nil] oss: sigaltstack_t): INTEGER; + + PROCEDURE [ccall] sigreturn* (ucontext_t: Ptrucontext_t): INTEGER; + + PROCEDURE [ccall] sigprocmask* (how: INTEGER; VAR [nil] set: sigset_t; VAR [nil] oset: sigset_t): INTEGER; + +END LinLibc. diff --git a/Trurl-based/_OpenBSD_/Lin/Mod/Termios.txt b/Trurl-based/_OpenBSD_/Lin/Mod/Termios.txt new file mode 100644 index 0000000..e4e729b --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Mod/Termios.txt @@ -0,0 +1,153 @@ +MODULE LinTermios ["libc.so.66.0"]; + + (* + A. V. Shiryaev, 2012.09 + + OpenBSD 5.2 + 32-bit + *) + + IMPORT SYSTEM; + + CONST + VEOF* = 0; (* ICANON *) + VEOL* = 1; (* ICANON *) + VERASE* = 3; (* ICANON *) + VKILL* = 5; (* ICANON *) + VINTR* = 8; (* ISIG *) + VQUIT* = 9; (* ISIG *) + VSUSP* = 10; (* ISIG *) + VSTART* = 12; (* IXON, IXOFF *) + VSTOP* = 13; (* IXON, IXOFF *) + VMIN* = 16; (* !ICANON *) + VTIME* = 17; (* !ICANON *) + NCCS* = 20; + IGNBRK* = 00000001H; (* ignore BREAK condition *) + BRKINT* = 00000002H; (* map BREAK to SIGINT *) + IGNPAR* = 00000004H; (* ignore (discard) parity errors *) + PARMRK* = 00000008H; (* mark parity and framing errors *) + INPCK* = 00000010H; (* enable checking of parity errors *) + ISTRIP* = 00000020H; (* strip 8th bit off chars *) + INLCR* = 00000040H; (* map NL into CR *) + IGNCR* = 00000080H; (* ignore CR *) + ICRNL* = 00000100H; (* map CR to NL (ala CRMOD) *) + IXON* = 00000200H; (* enable output flow control *) + IXOFF* = 00000400H; (* enable input flow control *) + OPOST* = 00000001H; (* enable following output processing *) + CSIZE* = 00000300H; (* character size mask *) + CS5* = 00000000H; (* 5 bits (pseudo) *) + CS6* = 00000100H; (* 6 bits *) + CS7* = 00000200H; (* 7 bits *) + CS8* = 00000300H; (* 8 bits *) + CSTOPB* = 00000400H; (* send 2 stop bits *) + CREAD* = 00000800H; (* enable receiver *) + PARENB* = 00001000H; (* parity enable *) + PARODD* = 00002000H; (* odd parity, else even *) + HUPCL* = 00004000H; (* hang up on last close *) + CLOCAL* = 00008000H; (* ignore modem status lines *) + ECHOE* = 00000002H; (* visually erase chars *) + ECHOK* = 00000004H; (* echo NL after line kill *) + ECHO* = 00000008H; (* enable echoing *) + ECHONL* = 00000010H; (* echo NL even if ECHO is off *) + ISIG* = 00000080H; (* enable signals INTR, QUIT, [D]SUSP *) + ICANON* = 00000100H; (* canonicalize input lines *) + IEXTEN* = 00000400H; (* enable DISCARD and LNEXT *) + EXTPROC* = 00000800H; (* external processing *) + TOSTOP* = 00400000H; (* stop background jobs from output *) + NOFLSH* = 80000000H; (* don't flush after interrupt *) + TCSANOW* = 0; (* make change immediate *) + TCSADRAIN* = 1; (* drain output, then change *) + TCSAFLUSH* = 2; (* drain output, flush input *) + B0* = 0; + B50* = 50; + B75* = 75; + B110* = 110; + B134* = 134; + B150* = 150; + B200* = 200; + B300* = 300; + B600* = 600; + B1200* = 1200; + B1800* = 1800; + B2400* = 2400; + B4800* = 4800; + B9600* = 9600; + B19200* = 19200; + B38400* = 38400; + VEOL2* = 2; (* ICANON *) + VWERASE* = 4; (* ICANON *) + VREPRINT* = 6; (* ICANON *) + VDSUSP* = 11; (* ISIG *) + VLNEXT* = 14; (* IEXTEN *) + VDISCARD* = 15; (* IEXTEN *) + VSTATUS* = 18; (* ICANON *) + IXANY* = 00000800H; (* any char will restart after stop *) + IUCLC* = 00001000H; (* translate upper to lower case *) + IMAXBEL* = 00002000H; (* ring bell on input queue full *) + ONLCR* = 00000002H; (* map NL to CR-NL (ala CRMOD) *) + OXTABS* = 00000004H; (* expand tabs to spaces *) + ONOEOT* = 00000008H; (* discard EOT's (^D) on output *) + OCRNL* = 00000010H; (* map CR to NL *) + OLCUC* = 00000020H; (* translate lower case to upper case *) + ONOCR* = 00000040H; (* No CR output at column 0 *) + ONLRET* = 00000080H; (* NL performs the CR function *) + CIGNORE* = 00000001H; (* ignore control flags *) + CRTSCTS* = 00010000H; (* RTS/CTS full-duplex flow control *) + CRTS_IFLOW* = CRTSCTS; (* XXX compat *) + CCTS_OFLOW* = CRTSCTS; (* XXX compat *) + MDMBUF* = 00100000H; (* DTR/DCD hardware flow control *) + ECHOKE* = 00000001H; (* visual erase for line kill *) + ECHOPRT* = 00000020H; (* visual erase mode for hardcopy *) + ECHOCTL* = 00000040H; (* echo control chars as ^(Char) *) + ALTWERASE* = 00000200H; (* use alternate WERASE algorithm *) + FLUSHO* = 00800000H; (* output being flushed (state) *) + XCASE* = 01000000H; (* canonical upper/lower case *) + NOKERNINFO* = 02000000H; (* no kernel output from VSTATUS *) + PENDIN* = 20000000H; (* XXX retype pending input (state) *) + TCSASOFT* = 10H; (* flag - don't alter h.w. state *) + B7200* = 7200; + B14400* = 14400; + B28800* = 28800; + B57600* = 57600; + B76800* = 76800; + B115200* = 115200; + B230400* = 230400; + EXTA* = 19200; + EXTB* = 38400; + TCIFLUSH* = 1; + TCOFLUSH* = 2; + TCIOFLUSH* = 3; + TCOOFF* = 1; + TCOON* = 2; + TCIOFF* = 3; + TCION* = 4; + + TYPE + tcflag_t* = INTEGER; (* unsigned int *) + cc_t* = SHORTCHAR; (* unsigned char *) + speed_t* = INTEGER; (* unsigned int *) + termios* = RECORD [untagged] + c_iflag*: tcflag_t; (* input flags *) + c_oflag*: tcflag_t; (* output flags *) + c_cflag*: tcflag_t; (* control flags *) + c_lflag*: tcflag_t; (* local flags *) + cc_t*: ARRAY [untagged] NCCS OF cc_t; (* control chars *) + c_ispeed*: INTEGER; (* input speed *) + c_ospeed*: INTEGER; (* output speed *) + END; + + (* POSIX.1 *) + PROCEDURE [ccall] cfgetispeed* (VAR tp: termios): speed_t; + PROCEDURE [ccall] cfsetispeed* (VAR tp: termios; ispeed: speed_t): INTEGER; + PROCEDURE [ccall] cfgetospeed* (VAR tp: termios): speed_t; + PROCEDURE [ccall] cfsetospeed* (VAR tp: termios; ospeed: speed_t): INTEGER; + PROCEDURE [ccall] tcgetattr* (fd: INTEGER; VAR tp: termios): INTEGER; + PROCEDURE [ccall] tcsetattr* (fd: INTEGER; action: INTEGER; VAR tp: termios): INTEGER; + + (* extensions *) +(* + PROCEDURE [ccall] cfsetspeed* (VAR tp: termios; speed: speed_t): INTEGER; + PROCEDURE [ccall] cfmakeraw* (VAR tp: termios); +*) + +END LinTermios. diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/BlackBox b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/BlackBox new file mode 100755 index 0000000..8090ec9 Binary files /dev/null and b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/BlackBox differ diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/Makefile b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/Makefile new file mode 100644 index 0000000..b3bdcd5 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/Makefile @@ -0,0 +1,33 @@ +# This is BSD Makefile +# BSD GNU +# ${.TARGET} $@ +# ${.ALLSRC} $^ +# ${.IMPSRC} $< + +CFLAGS += -Wall -O0 -g + +all: libdlobsdwrap.so dev0 BlackBox + +# libdlobsdwrap.so: universal method of correct access to dl* functions +# in case of dynamic loading of libBB*.so "ld.so" in LibDl may be used instead of "libc.so", but not in case of static linking +# wrapper method is universal + +# -pthread required to dlopen libraries that depends on pthread + +#BlackBox: BlackBox.c +# ${CC} ${CFLAGS} -o ${.TARGET} ${.ALLSRC} -L. -lBB -pthread + +BlackBox: BlackBox-dl.c + ${CC} ${CFLAGS} -o ${.TARGET} ${.ALLSRC} -pthread + +#dev0: BlackBox1.c +# ${CC} ${CFLAGS} -o ${.TARGET} ${.ALLSRC} -L . -lBB0 + +dev0: dev0.c + ${CC} ${CFLAGS} -o ${.TARGET} ${.ALLSRC} + +libdlobsdwrap.so: libdlobsdwrap.c + ${CC} ${CFLAGS} -o ${.TARGET} ${.ALLSRC} -fPIC -shared + +clean: + rm -f dev0 BlackBox libdlobsdwrap.so diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/dev0 b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/dev0 new file mode 100755 index 0000000..b145e7a Binary files /dev/null and b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/dev0 differ diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB.so b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB.so new file mode 120000 index 0000000..85c28c4 --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB.so @@ -0,0 +1 @@ +../../../libBB.so \ No newline at end of file diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB0.so b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB0.so new file mode 120000 index 0000000..6319f6b --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB0.so @@ -0,0 +1 @@ +../../../libBB0.so \ No newline at end of file diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.c b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.c new file mode 100644 index 0000000..22c437b --- /dev/null +++ b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.c @@ -0,0 +1,21 @@ +#include + +void * __dlopen (const char *path, int mode) +{ + return dlopen(path, mode); +} + +int __dlclose (void *handle) +{ + return dlclose(handle); +} + +void * __dlsym (void *handle, const char *symbol) +{ + return dlsym(handle, symbol); +} + +const char * __dlerror (void) +{ + return dlerror(); +} diff --git a/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.so b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.so new file mode 100755 index 0000000..8874e67 Binary files /dev/null and b/Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.so differ diff --git a/Trurl-based/_OpenBSD_/System/Mod/Kernel.odc b/Trurl-based/_OpenBSD_/System/Mod/Kernel.odc new file mode 100644 index 0000000..56ff927 Binary files /dev/null and b/Trurl-based/_OpenBSD_/System/Mod/Kernel.odc differ diff --git a/Trurl-based/_OpenBSD_/System/Mod/Kernel.txt b/Trurl-based/_OpenBSD_/System/Mod/Kernel.txt new file mode 100644 index 0000000..99b1862 --- /dev/null +++ b/Trurl-based/_OpenBSD_/System/Mod/Kernel.txt @@ -0,0 +1,2153 @@ +MODULE Kernel; + + (* THIS IS TEXT COPY OF Kernel.odc *) + (* DO NOT EDIT *) + + (* A. V. Shiryaev, 2012.11 + OpenBSD Kernel + Based on 1.6-rc6 Windows Kernel + + 20120822 Marc changes + Some parts taken from OpenBUGS linKernel + + Most Windows-specific code removed + Some Windows-specific code commented and marked red + Windows COM-specific code re-marked from green to gray + OpenBSD(/Linux)-specific code marked green + + TODO: + handle stack overflow exceptions + Quit from TrapHandler + *) + + IMPORT S := SYSTEM, Libc := LinLibc, Dl := LinDl; + + CONST + strictStackSweep = TRUE; + + nameLen* = 256; + + littleEndian* = TRUE; + timeResolution* = 1000; (* ticks per second *) + + processor* = 10; (* i386 *) + + objType* = "ocf"; (* file types *) + symType* = "osf"; + docType* = "odc"; + + (* loader constants *) + done* = 0; + fileNotFound* = 1; + syntaxError* = 2; + objNotFound* = 3; + illegalFPrint* = 4; + cyclicImport* = 5; + noMem* = 6; + commNotFound* = 7; + commSyntaxError* = 8; + moduleNotFound* = 9; + + any = 1000000; + + CX = 1; + SP = 4; (* register number of stack pointer *) + FP = 5; (* register number of frame pointer *) + ML = 3; (* register which holds the module list at program start *) + + N = 128 DIV 16; (* free lists *) + + (* kernel flags in module desc *) + init = 16; dyn = 17; dll = 24; iptrs = 30; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + + debug = FALSE; + + +(* + sigStackSize = MAX(Libc.SIGSTKSZ, 65536); +*) + + trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *) + + (* constants for the message boxes *) + mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5; + + TYPE + Name* = ARRAY nameLen OF SHORTCHAR; + Command* = PROCEDURE; + + Module* = POINTER TO RECORD [untagged] + next-: Module; + opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *) + refcnt-: INTEGER; (* <0: module invalidated *) + compTime-, loadTime-: ARRAY 6 OF SHORTINT; + ext-: INTEGER; (* currently not used *) + term-: Command; (* terminator *) + nofimps-, nofptrs-: INTEGER; + csize-, dsize-, rsize-: INTEGER; + code-, data-, refs-: INTEGER; + procBase-, varBase-: INTEGER; (* meta base addresses *) + names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *) + ptrs-: POINTER TO ARRAY [untagged] OF INTEGER; + imports-: POINTER TO ARRAY [untagged] OF Module; + export-: Directory; (* exported objects (name sorted) *) + name-: Name + END; + + Type* = POINTER TO RECORD [untagged] + (* record: ptr to method n at offset - 4 * (n+1) *) + size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *) + mod-: Module; + id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *) + base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *) + fields-: Directory; (* new fields (declaration order) *) + ptroffs-: ARRAY any OF INTEGER (* array of any length *) + END; + + Object* = POINTER TO ObjDesc; + + ObjDesc* = RECORD [untagged] + fprint-: INTEGER; + offs-: INTEGER; (* pvfprint for record types *) + id-: INTEGER; (* name idx * 256 + vis * 16 + mode *) + struct-: Type (* id of basic type or pointer to typedesc/signature *) + END; + + Directory* = POINTER TO RECORD [untagged] + num-: INTEGER; (* number of entries *) + obj-: ARRAY any OF ObjDesc (* array of any length *) + END; + + Signature* = POINTER TO RECORD [untagged] + retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *) + num-: INTEGER; (* number of parameters *) + par-: ARRAY any OF RECORD [untagged] (* parameters *) + id-: INTEGER; (* name idx * 256 + kind *) + struct-: Type (* id of basic type or pointer to typedesc *) + END + END; + + Handler* = PROCEDURE; + + Reducer* = POINTER TO ABSTRACT RECORD + next: Reducer + END; + + Identifier* = ABSTRACT RECORD + typ*: INTEGER; + obj-: ANYPTR + END; + + TrapCleaner* = POINTER TO ABSTRACT RECORD + next: TrapCleaner + END; + + TryHandler* = PROCEDURE (a, b, c: INTEGER); + + + (* meta extension suport *) + + ItemExt* = POINTER TO ABSTRACT RECORD END; + + ItemAttr* = RECORD + obj*, vis*, typ*, adr*: INTEGER; + mod*: Module; + desc*: Type; + ptr*: S.PTR; + ext*: ItemExt + END; + + Hook* = POINTER TO ABSTRACT RECORD END; + + LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) + res*: INTEGER; + importing*, imported*, object*: ARRAY 256 OF CHAR + END; + + GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *) + + Block = POINTER TO RECORD [untagged] + tag: Type; + last: INTEGER; (* arrays: last element *) + actual: INTEGER; (* arrays: used during mark phase *) + first: INTEGER (* arrays: first element *) + END; + + FreeBlock = POINTER TO FreeDesc; + + FreeDesc = RECORD [untagged] + tag: Type; (* f.tag = ADR(f.size) *) + size: INTEGER; + next: FreeBlock + END; + + Cluster = POINTER TO RECORD [untagged] + size: INTEGER; (* total size *) + next: Cluster; + max: INTEGER + (* start of first block *) + END; + + FList = POINTER TO RECORD + next: FList; + blk: Block; + iptr, aiptr: BOOLEAN + END; + + CList = POINTER TO RECORD + next: CList; + do: Command; + trapped: BOOLEAN + END; + + + PtrType = RECORD v: S.PTR END; (* used for array of pointer *) + Char8Type = RECORD v: SHORTCHAR END; + Char16Type = RECORD v: CHAR END; + Int8Type = RECORD v: BYTE END; + Int16Type = RECORD v: SHORTINT END; + Int32Type = RECORD v: INTEGER END; + Int64Type = RECORD v: LONGINT END; + BoolType = RECORD v: BOOLEAN END; + SetType = RECORD v: SET END; + Real32Type = RECORD v: SHORTREAL END; + Real64Type = RECORD v: REAL END; + ProcType = RECORD v: PROCEDURE END; + UPtrType = RECORD v: INTEGER END; + StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + (* Linux specific boot loader info. Record must be identical to struct in the loader. *) + BootInfo* = POINTER TO RECORD [untagged] + modList: Module; + argc-: INTEGER; + argv-: Libc.StrArray + END; + + VAR + baseStack: INTEGER; (* modList, root, and baseStack must be together for remote debugging *) + root: Cluster; (* cluster list *) + modList-: Module; (* root of module list *) + trapCount-: INTEGER; + err-, pc-, sp-, fp-, stack-, val-: INTEGER; + + free: ARRAY N OF FreeBlock; (* free list *) + sentinelBlock: FreeDesc; + sentinel: FreeBlock; + candidates: ARRAY 1024 OF INTEGER; + nofcand: INTEGER; + allocated: INTEGER; (* bytes allocated on BlackBox heap *) + total: INTEGER; (* current total size of BlackBox heap *) + used: INTEGER; (* bytes allocated on system heap *) + finalizers: FList; + hotFinalizers: FList; + cleaners: CList; + reducers: Reducer; + trapStack: TrapCleaner; + actual: Module; (* valid during module initialization *) + + res: INTEGER; (* auxiliary global variables used for trap handling *) + old: INTEGER; + + trapViewer, trapChecker: Handler; + trapped, guarded, secondTrap: BOOLEAN; + interrupted: BOOLEAN; + static, inDll, terminating: BOOLEAN; + restart: Command; + + told, shift: INTEGER; (* used in Time() *) + + loader: LoaderHook; + loadres: INTEGER; + + wouldFinalize: BOOLEAN; + + watcher*: PROCEDURE (event: INTEGER); (* for debugging *) + + +(* + sigStack: Libc.PtrVoid; +*) + + loopContext: Libc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *) + currentTryContext: POINTER TO Libc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *) + isReadableContext: Libc.sigjmp_buf; (* for IsReadable *) + isReadableCheck: BOOLEAN; + + guiHook: GuiHook; + + (* !!! This variable has to be the last variable in the list. !!! *) + bootInfo-: BootInfo; + + (* code procedures for fpu *) + + PROCEDURE [1] FINIT 0DBH, 0E3H; + PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH; (* -4, FP *) + PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH; (* -4, FP *) + + (* code procedure for memory erase *) + + PROCEDURE [code] Erase (adr, words: INTEGER) + 089H, 0C7H, (* MOV EDI, EAX *) + 031H, 0C0H, (* XOR EAX, EAX *) + 059H, (* POP ECX *) + 0F2H, 0ABH; (* REP STOS *) + + (* code procedure for stack allocate *) + + PROCEDURE [code] ALLOC (* argument in CX *) + (* + PUSH EAX + ADD ECX,-5 + JNS L0 + XOR ECX,ECX + L0: AND ECX,-4 (n-8+3)/4*4 + MOV EAX,ECX + AND EAX,4095 + SUB ESP,EAX + MOV EAX,ECX + SHR EAX,12 + JEQ L2 + L1: PUSH 0 + SUB ESP,4092 + DEC EAX + JNE L1 + L2: ADD ECX,8 + MOV EAX,[ESP,ECX,-4] + PUSH EAX + MOV EAX,[ESP,ECX,-4] + SHR ECX,2 + RET + *); + + PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; + + + (* meta extension suport *) + + PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + + + (* -------------------- miscellaneous tools -------------------- *) + + PROCEDURE Msg (IN str: ARRAY OF CHAR); + VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER; + BEGIN + ss := SHORT(str); + l := LEN(ss$); + ss[l] := 0AX; ss[l + 1] := 0X; + res := Libc.printf(ss) + END Msg; + + PROCEDURE Int (x: LONGINT); + VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR; + BEGIN + IF x # MIN(LONGINT) THEN + IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; + j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 + ELSE + a := "8085774586302733229"; s[0] := "-"; k := 1; + j := 0; WHILE a[j] # 0X DO INC(j) END + END; + ASSERT(k + j < LEN(s), 20); + REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; + s[k] := 0X; + Msg(s); + END Int; + + PROCEDURE (h: GuiHook) MessageBox* ( + title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT; + PROCEDURE (h: GuiHook) Beep*, NEW, ABSTRACT; + + (* Is extended by HostGnome to show dialogs. If no dialog is present or + if the dialog is not closed by using one button, then "mbClose" is returned *) + PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER; + VAR res: INTEGER; + BEGIN + IF guiHook # NIL THEN + res := guiHook.MessageBox(title, msg, buttons) + ELSE + Msg(" "); + Msg("****"); + Msg("* " + title); + Msg("* " + msg); + Msg("****"); + res := mbClose; + END; + RETURN res + END MessageBox; + + PROCEDURE SetGuiHook* (hook: GuiHook); + BEGIN + guiHook := hook + END SetGuiHook; + + PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); + (* portable *) + VAR i, j: INTEGER; ch, lch: CHAR; + BEGIN + i := 0; ch := name[0]; + IF ch # 0X THEN + REPEAT + head[i] := ch; lch := ch; INC(i); ch := name[i] + UNTIL (ch = 0X) + OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ")) + & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ")); + head[i] := 0X; j := 0; + WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; + tail[j] := 0X; + IF tail = "" THEN tail := head$; head := "" END + ELSE head := ""; tail := "" + END + END SplitName; + + PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; + BEGIN + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSIF i < LEN(name) - 4 THEN + IF type = "" THEN ext := docType ELSE ext := type$ END; + name[i] := "."; INC(i); j := 0; ch := ext[0]; + WHILE ch # 0X DO + IF (ch >= "A") & (ch <= "Z") THEN + ch := CHR(ORD(ch) + ORD("a") - ORD("A")) + END; + name[i] := ch; INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END MakeFileName; + + PROCEDURE Time* (): LONGINT; + VAR t: INTEGER; + BEGIN + (* t := WinApi.GetTickCount(); *) + + (* A. V. Shiryaev: OpenBSD *) + ASSERT(Libc.CLOCKS_PER_SEC = 100); + t := 10 * Libc.clock(); + + IF t < told THEN INC(shift) END; + told := t; + RETURN shift * 100000000L + t + END Time; + + PROCEDURE Beep* (); + VAR ss: ARRAY 2 OF SHORTCHAR; + BEGIN + IF guiHook # NIL THEN + guiHook.Beep + ELSE + ss[0] := 007X; ss[1] := 0X; + res := Libc.printf(ss); res := Libc.fflush(Libc.NULL) + END + END Beep; + + PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); + BEGIN + adr := var; m := NIL; + IF var # 0 THEN + m := modList; + WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; + IF m # NIL THEN DEC(adr, m.code) END + END + END SearchProcVar; + + + (* -------------------- system memory management --------------------- *) + + (* A. V. Shiryaev, 2012.10: NOTE: it seems that GC works correctly with positive addesses only *) + +(* + PROCEDURE HeapAlloc (adr: INTEGER; size: INTEGER; prot: SET): Libc.PtrVoid; + VAR + x: Libc.PtrVoid; + res: INTEGER; + BEGIN + x := Libc.calloc(1, size); (* calloc initialize allocated space to zero *) + IF x # Libc.NULL THEN + res := Libc.mprotect(x, size, prot); + IF res # 0 THEN + Libc.free(x); + x := Libc.NULL; + Msg("Kernel.HeapAlloc: mprotect failed!"); + HALT(100) + END + END; + RETURN x + END HeapAlloc; +*) + PROCEDURE HeapAlloc (adr: Libc.PtrVoid; size: INTEGER; prot: SET): Libc.PtrVoid; + VAR x: Libc.PtrVoid; + BEGIN + x := Libc.mmap(adr, size, prot, Libc.MAP_PRIVATE + Libc.MAP_ANON, -1, 0); + IF x = Libc.MAP_FAILED THEN + x := Libc.NULL + ELSE + ASSERT(size MOD 4 = 0, 100); + Erase(x, size DIV 4) + END; + RETURN x + END HeapAlloc; + +(* + PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); + VAR res: INTEGER; + BEGIN +(* + ASSERT(size MOD 4 = 0, 100); + Erase(adr, size DIV 4); + res := Libc.mprotect(adr, size, Libc.PROT_NONE); + ASSERT(res = 0, 101); +*) + Libc.free(adr) + END HeapFree; +*) + PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); + VAR res: INTEGER; + BEGIN +(* + ASSERT(size MOD 4 = 0, 100); + Erase(adr, size DIV 4); + res := Libc.mprotect(adr, size, Libc.PROT_NONE); + ASSERT(res = 0, 101); +*) + res := Libc.munmap(adr, size); + ASSERT(res = 0, 102) + END HeapFree; + + PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); + (* allocate at least size bytes, typically at least 256 kbytes are allocated *) + CONST N = 65536; (* cluster size for dll *) + prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); + VAR adr: INTEGER; + allocated: INTEGER; + BEGIN + INC(size, 16); + ASSERT(size > 0, 100); adr := 0; + IF size < N THEN adr := HeapAlloc(1, N, prot) END; + IF adr = 0 THEN adr := HeapAlloc(1, size, prot); allocated := size ELSE allocated := N END; + IF adr = 0 THEN c := NIL + ELSE + c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr; + c.size := allocated - (S.VAL(INTEGER, c) - adr); + INC(used, c.size); INC(total, c.size) + END + (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) + END AllocHeapMem; + + PROCEDURE FreeHeapMem (c: Cluster); + BEGIN + DEC(used, c.size); DEC(total, c.size); + HeapFree(c.max, (S.VAL(INTEGER, c) - c.max) + c.size) + END FreeHeapMem; + + PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); + CONST + prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); + BEGIN + descAdr := HeapAlloc(0, descSize, prot); + IF descAdr # 0 THEN + modAdr := HeapAlloc(0, modSize, prot); + IF modAdr # 0 THEN INC(used, descSize + modSize) + ELSE HeapFree(descAdr, descSize); descAdr := 0 + END + ELSE modAdr := 0 + END + END AllocModMem; + + PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); + BEGIN + DEC(used, descSize + modSize); + HeapFree(descAdr, descSize); + HeapFree(modAdr, modSize) + END DeallocModMem; + + PROCEDURE InvalModMem (modSize, modAdr: INTEGER); + BEGIN + DEC(used, modSize); + HeapFree(modAdr, modSize) + END InvalModMem; + +(* + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + (* check wether memory between from (incl.) and to (excl.) may be read *) + BEGIN + RETURN WinApi.IsBadReadPtr(from, to - from) = 0 + END IsReadable; +*) + + (* Alexander Shiryaev, 2012.10: I do not know other way that works in OpenBSD *) + (* This procedure can be called from TrapHandler also *) + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + (* check wether memory between from (incl.) and to (excl.) may be read *) + VAR res: BOOLEAN; res1: INTEGER; + x: SHORTCHAR; + mask, omask: Libc.sigset_t; + BEGIN + (* save old sigmask and unblock SIGSEGV *) + res1 := Libc.sigemptyset(S.ADR(mask)); + ASSERT(res1 = 0, 100); + res1 := Libc.sigaddset(S.ADR(mask), Libc.SIGSEGV); + ASSERT(res1 = 0, 101); + res1 := Libc.sigprocmask(Libc.SIG_UNBLOCK, mask, omask); + ASSERT(res1 = 0, 102); + + res := FALSE; + res1 := Libc.sigsetjmp(isReadableContext, Libc.TRUE); + IF res1 = 0 THEN + isReadableCheck := TRUE; + (* read memory *) + REPEAT + S.GET(from, x); + INC(from) + UNTIL from = to; + res := TRUE + ELSE + ASSERT(res1 = 1, 103) + END; + isReadableCheck := FALSE; + + (* restore saved sigmask *) + res1 := Libc.sigprocmask(Libc.SIG_SETMASK, omask, NIL); + ASSERT(res1 = 0, 104); + + RETURN res + END IsReadable; + + (* --------------------- NEW implementation (portable) -------------------- *) + + PROCEDURE^ NewBlock (size: INTEGER): Block; + + PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) + VAR size: INTEGER; b: Block; tag: Type; l: FList; + BEGIN + IF ODD(typ) THEN (* record contains interface pointers *) + tag := S.VAL(Type, typ - 1); + b := NewBlock(tag.size); + IF b = NIL THEN RETURN 0 END; + b.tag := tag; + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.iptr := TRUE; l.next := finalizers; finalizers := l; + RETURN S.ADR(b.last) + ELSE + tag := S.VAL(Type, typ); + b := NewBlock(tag.size); + IF b = NIL THEN RETURN 0 END; + b.tag := tag; S.GET(typ - 4, size); + IF size # 0 THEN (* record uses a finalizer *) + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.next := finalizers; finalizers := l + END; + RETURN S.ADR(b.last) + END + END NewRec; + + PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) + VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList; + BEGIN + IF (nofdim < 0)OR(nofdim>1FFFFFFCH) THEN RETURN 0 END;(*20120822 Marc*) + headSize := 4 * nofdim + 12; fin := FALSE; + CASE eltyp OF +(* + | -1: eltyp := S.ADR(IntPtrType); fin := TRUE +*) + | -1: HALT(100) + | 0: eltyp := S.ADR(PtrType) + | 1: eltyp := S.ADR(Char8Type) + | 2: eltyp := S.ADR(Int16Type) + | 3: eltyp := S.ADR(Int8Type) + | 4: eltyp := S.ADR(Int32Type) + | 5: eltyp := S.ADR(BoolType) + | 6: eltyp := S.ADR(SetType) + | 7: eltyp := S.ADR(Real32Type) + | 8: eltyp := S.ADR(Real64Type) + | 9: eltyp := S.ADR(Char16Type) + | 10: eltyp := S.ADR(Int64Type) + | 11: eltyp := S.ADR(ProcType) + | 12: eltyp := S.ADR(UPtrType) + ELSE (* eltyp is desc *) + IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END + END; + t := S.VAL(Type, eltyp); + ASSERT(t .size> 0,100); + IF (nofelem < 0) OR( (7FFFFFFFH-headSize) DIV t.size < nofelem) THEN (* 20120822 Marc*) + RETURN 0 + END; + size := headSize + nofelem * t.size; + b := NewBlock(size); + IF b = NIL THEN RETURN 0 END; + b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) + b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) + b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) + IF fin THEN + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.aiptr := TRUE; l.next := finalizers; finalizers := l + END; + RETURN S.ADR(b.last) + END NewArr; + + + (* -------------------- handler installation (portable) --------------------- *) + + PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; + VAR l: FList; + BEGIN + ASSERT(id.typ # 0, 100); + l := finalizers; + WHILE l # NIL DO + IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN + id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); + IF id.Identified() THEN RETURN id.obj END + END; + l := l.next + END; + RETURN NIL + END ThisFinObj; + + PROCEDURE InstallReducer* (r: Reducer); + BEGIN + r.next := reducers; reducers := r + END InstallReducer; + + PROCEDURE InstallTrapViewer* (h: Handler); + BEGIN + trapViewer := h + END InstallTrapViewer; + + PROCEDURE InstallTrapChecker* (h: Handler); + BEGIN + trapChecker := h + END InstallTrapChecker; + + PROCEDURE PushTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; + ASSERT(t = NIL, 20); + c.next := trapStack; trapStack := c + END PushTrapCleaner; + + PROCEDURE PopTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := NIL; + WHILE (trapStack # NIL) & (t # c) DO + t := trapStack; trapStack := trapStack.next + END + END PopTrapCleaner; + + PROCEDURE InstallCleaner* (p: Command); + VAR c: CList; + BEGIN + c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) + c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c + END InstallCleaner; + + PROCEDURE RemoveCleaner* (p: Command); + VAR c0, c: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; + IF c # NIL THEN + IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END + END + END RemoveCleaner; + + PROCEDURE Cleanup*; + VAR c, c0: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE c # NIL DO + IF ~c.trapped THEN + c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c + ELSE + IF c0 = NIL THEN cleaners := cleaners.next + ELSE c0.next := c.next + END + END; + c := c.next + END + END Cleanup; + + (* -------------------- meta information (portable) --------------------- *) + + PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF SHORTCHAR): Module, NEW, ABSTRACT; + + PROCEDURE SetLoaderHook*(h: LoaderHook); + BEGIN + loader := h + END SetLoaderHook; + + PROCEDURE InitModule (mod: Module); (* initialize linked modules *) + VAR body: Command; + res: INTEGER; errno: INTEGER; + BEGIN + IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; + IF ~(init IN mod.opts) THEN + body := S.VAL(Command, mod.code); + INCL(mod.opts, init); + actual := mod; + + (* A. V. Shiryaev: Allow execution on code pages *) + res := Libc.mprotect(mod.code, mod.csize, + Libc.PROT_READ + Libc.PROT_WRITE + Libc.PROT_EXEC); + IF res = -1 THEN + S.GET( Libc.__errno_location(), errno ); + Msg("ERROR: Kernel.InitModule: mprotect failed!"); + Msg(mod.name$); Int(mod.code); Int(mod.csize); Int(errno); + HALT(100) + ELSE ASSERT(res = 0) + END; + + body(); actual := NIL + END + END InitModule; + + PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module; (* loaded modules only *) + VAR m: Module; + BEGIN + loadres := done; + m := modList; + WHILE (m # NIL) & ((m.name # name) OR (m.refcnt < 0)) DO m := m.next END; + IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; + IF m = NIL THEN loadres := moduleNotFound END; + RETURN m + END ThisLoadedMod; + + PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; + VAR n : Name; + BEGIN + n := SHORT(name$); + IF loader # NIL THEN + loader.res := done; + RETURN loader.ThisMod(n) + ELSE + RETURN ThisLoadedMod(n) + END + END ThisMod; + + PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); + VAR m: Module; + BEGIN + m := ThisMod(name) + END LoadMod; + + PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); + BEGIN + IF loader # NIL THEN + res := loader.res; + importing := loader.importing$; + imported := loader.imported$; + object := loader.object$ + ELSE + res := loadres; + importing := ""; + imported := ""; + object := "" + END + END GetLoaderResult; + + PROCEDURE ThisObject* (mod: Module; name: ARRAY OF SHORTCHAR): Object; + VAR l, r, m: INTEGER; p: StrPtr; + BEGIN + l := 0; r := mod.export.num; + WHILE l < r DO (* binary search *) + m := (l + r) DIV 2; + p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); + IF p^ = name THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; + IF p^ < name THEN l := m + 1 ELSE r := m END + END; + RETURN NIL + END ThisObject; + + PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; + VAR i, n: INTEGER; + BEGIN + i := 0; n := mod.export.num; + WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO + IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; + INC(i) + END; + RETURN NIL + END ThisDesc; + + PROCEDURE ThisField* (rec: Type; name: ARRAY OF SHORTCHAR): Object; + VAR n: INTEGER; p: StrPtr; obj: Object; m: Module; + BEGIN + m := rec.mod; + obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; + WHILE n > 0 DO + p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); + IF p^ = name THEN RETURN obj END; + DEC(n); INC(S.VAL(INTEGER, obj), 16) + END; + RETURN NIL + END ThisField; + + PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command; + VAR x: Object; sig: Signature; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mProc) THEN + sig := S.VAL(Signature, x.struct); + IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END + END; + RETURN NIL + END ThisCommand; + + PROCEDURE ThisType* (mod: Module; name: ARRAY OF SHORTCHAR): Type; + VAR x: Object; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN + RETURN x.struct + ELSE + RETURN NIL + END + END ThisType; + + PROCEDURE TypeOf* (IN rec: ANYREC): Type; + BEGIN + RETURN S.VAL(Type, S.TYP(rec)) + END TypeOf; + + PROCEDURE LevelOf* (t: Type): SHORTINT; + BEGIN + RETURN SHORT(t.id DIV 16 MOD 16) + END LevelOf; + + PROCEDURE NewObj* (VAR o: S.PTR; t: Type); + VAR i: INTEGER; + BEGIN + IF t.size = -1 THEN o := NIL + ELSE + i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; + IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) + o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) + END + END NewObj; + + PROCEDURE GetObjName* (mod: Module; obj: Object; VAR name: Name); + VAR p: StrPtr; + BEGIN + p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); + name := p^$ + END GetObjName; + + PROCEDURE GetTypeName* (t: Type; VAR name: Name); + VAR p: StrPtr; + BEGIN + p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); + name := p^$ + END GetTypeName; + + PROCEDURE RegisterMod* (mod: Module); + VAR i: INTEGER; + t: Libc.time_t; tm: Libc.tm; + BEGIN + mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; + WHILE i < mod.nofimps DO + IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; + INC(i) + END; + + t := Libc.time(NIL); + tm := Libc.localtime(t); + mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *) + mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *); + mod.loadTime[2] := SHORT(tm.tm_mday); + mod.loadTime[3] := SHORT(tm.tm_hour); + mod.loadTime[4] := SHORT(tm.tm_min); + mod.loadTime[5] := SHORT(tm.tm_sec); + tm := NIL; + + IF ~(init IN mod.opts) THEN InitModule(mod) END + END RegisterMod; + + PROCEDURE^ Collect*; + + PROCEDURE UnloadMod* (mod: Module); + VAR i: INTEGER; t: Command; + BEGIN + IF mod.refcnt = 0 THEN + t := mod.term; mod.term := NIL; + IF t # NIL THEN t() END; (* terminate module *) + i := 0; + WHILE i < mod.nofptrs DO (* release global pointers *) + S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) + END; +(* + ReleaseIPtrs(mod); (* release global interface pointers *) +*) + Collect; (* call finalizers *) + i := 0; + WHILE i < mod.nofimps DO (* release imported modules *) + IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; + INC(i) + END; + mod.refcnt := -1; + IF dyn IN mod.opts THEN (* release memory *) + InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) + END + END + END UnloadMod; + + (* -------------------- dynamic procedure call --------------------- *) (* COMPILER DEPENDENT *) + + PROCEDURE [1] PUSH (p: INTEGER) 050H; (* push AX *) + PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H; (* call AX *) + PROCEDURE [1] RETI (): LONGINT; + PROCEDURE [1] RETR (): REAL; + + (* + type par + 32 bit scalar value + 64 bit scalar low hi + var scalar address + record address tag + array address size + open array address length .. length + *) + + PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; + VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL; + BEGIN + p := sig.num; + WHILE p > 0 DO (* push parameters from right to left *) + DEC(p); + typ := sig.par[p].struct; + kind := sig.par[p].id MOD 16; + IF (S.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN (* scalar *) + IF (kind = 10) & ((S.VAL(INTEGER, typ) = 8) OR (S.VAL(INTEGER, typ) = 10)) THEN (* 64 bit *) + DEC(n); PUSH(par[n]) (* push hi word *) + END; + DEC(n); PUSH(par[n]) (* push value/address *) + ELSIF typ.id MOD 4 = 1 THEN (* record *) + IF kind # 10 THEN (* var par *) + DEC(n); PUSH(par[n]); (* push tag *) + DEC(n); PUSH(par[n]) (* push address *) + ELSE + DEC(n, 2); (* skip tag *) + S.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) + S.MOVE(par[n], sp, typ.size) (* copy to stack *) + END + ELSIF typ.size = 0 THEN (* open array *) + size := typ.id DIV 16 MOD 16; (* number of open dimensions *) + WHILE size > 0 DO + DEC(size); DEC(n); PUSH(par[n]) (* push length *) + END; + DEC(n); PUSH(par[n]) (* push address *) + ELSE (* fix array *) + IF kind # 10 THEN (* var par *) + DEC(n, 2); PUSH(par[n]) (* push address *) + ELSE + DEC(n); size := par[n]; DEC(n); + S.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) + S.MOVE(par[n], sp, size) (* copy to stack *) + END + END + END; + ASSERT(n = 0); + IF S.VAL(INTEGER, sig.retStruct) = 7 THEN (* shortreal *) + CALL(adr); + RETURN S.VAL(INTEGER, SHORT(RETR())) (* return value in fpu register *) + ELSIF S.VAL(INTEGER, sig.retStruct) = 8 THEN (* real *) + CALL(adr); r := RETR(); + RETURN S.VAL(LONGINT, r) (* return value in fpu register *) + ELSE + CALL(adr); + RETURN RETI() (* return value in integer registers *) + END + END Call; + + (* -------------------- reference information (portable) --------------------- *) + + PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR); + BEGIN + S.GET(ref, ch); INC(ref) + END RefCh; + + PROCEDURE RefNum (VAR ref: INTEGER; VAR x: INTEGER); + VAR s, n: INTEGER; ch: SHORTCHAR; + BEGIN + s := 0; n := 0; RefCh(ref, ch); + WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; + x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) + END RefNum; + + PROCEDURE RefName (VAR ref: INTEGER; VAR n: Name); + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; RefCh(ref, ch); + WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; + n[i] := 0X + END RefName; + + PROCEDURE GetRefProc* (VAR ref: INTEGER; VAR adr: INTEGER; VAR name: Name); + VAR ch: SHORTCHAR; + BEGIN + S.GET(ref, ch); + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) + END; + WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) + INC(ref); RefNum(ref, adr); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) + ELSE adr := 0 + END + END GetRefProc; + + (* A. V. Shiryaev, 2012.11 *) + PROCEDURE CheckRefVarReadable (ref: INTEGER): BOOLEAN; + VAR ok: BOOLEAN; ch: SHORTCHAR; + p: INTEGER; (* address *) + + PROCEDURE Get; + BEGIN + IF ok THEN + IF IsReadable(ref, ref+1) THEN (* S.GET(ref, ch); INC(ref) *) RefCh(ref, ch) + ELSE ok := FALSE + END + END + END Get; + + PROCEDURE Num; + BEGIN + Get; WHILE ok & (ORD(ch) >= 128) DO Get END + END Num; + + PROCEDURE Name; + BEGIN + Get; WHILE ok & (ch # 0X) DO Get END + END Name; + + BEGIN + ok := TRUE; + Get; (* mode *) + IF ok & (ch >= 0FDX) THEN + Get; (* form *) + IF ok & (ch = 10X) THEN + IF IsReadable(ref, ref + 4) THEN (* desc *) + S.GET(ref, p); INC(ref, 4); + ok := IsReadable(p + 2 * 4, p + 3 * 4) (* desc.id *) + ELSE ok := FALSE + END + END; + Num; Name + END; + RETURN ok + END CheckRefVarReadable; + + PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type; + VAR adr: INTEGER; VAR name: Name); + BEGIN + IF CheckRefVarReadable(ref) THEN + S.GET(ref, mode); desc := NIL; + IF mode >= 0FDX THEN + mode := SHORT(CHR(ORD(mode) - 0FCH)); + INC(ref); RefCh(ref, form); + IF form = 10X THEN + S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) + END; + RefNum(ref, adr); RefName(ref, name) + ELSE + mode := 0X; form := 0X; adr := 0 + END + ELSE + Msg("Kernel.GetRefVar failed!"); Int(ref); + mode := 0X; form := 0X; adr := 0 + END + END GetRefVar; + + PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; + VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Name; + BEGIN + ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); + WHILE ch # 0X DO + WHILE (ch > 0X) & (ch < 0FCX) DO + INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); + IF ad > codePos THEN RETURN pos END; + INC(pos, d); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END; + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) + END + END; + RETURN -1 + END SourcePos; + + (* -------------------- dynamic link libraries --------------------- *) + +(* + PROCEDURE DlOpen (name: ARRAY OF SHORTCHAR): Dl.HANDLE; + CONST flags = Dl.RTLD_LAZY + Dl.RTLD_GLOBAL; + VAR h: Dl.HANDLE; + i: INTEGER; + BEGIN + h := Dl.NULL; + i := 0; WHILE (i < LEN(name)) & (name[i] # 0X) DO INC(i) END; + IF i < LEN(name) THEN + h := Dl.dlopen(name, flags); + WHILE (h = Dl.NULL) & (i > 0) DO + DEC(i); + WHILE (i > 0) & (name[i] # '.') DO DEC(i) END; + IF i > 0 THEN + name[i] := 0X; + h := Dl.dlopen(name, flags); + (* IF h # Dl.NULL THEN Msg(name$) END *) + END + END + END; + RETURN h + END DlOpen; +*) + + PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN); + VAR h: Dl.HANDLE; + BEGIN + ok := FALSE; + h := Dl.dlopen(name, Dl.RTLD_LAZY + Dl.RTLD_GLOBAL); + IF h # Dl.NULL THEN ok := TRUE END + END LoadDll; + + PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER; + VAR ad: INTEGER; h: Dl.HANDLE; + BEGIN + ad := 0; + IF mode IN {mVar, mProc} THEN + h := Dl.dlopen(dll, Dl.RTLD_LAZY+ Dl.RTLD_GLOBAL); + IF h # Dl.NULL THEN + ad := Dl.dlsym(h, name); + END + END; + RETURN ad + END ThisDllObj; + + (* -------------------- garbage collector (portable) --------------------- *) + + PROCEDURE Mark (this: Block); + VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; + BEGIN + IF ~ODD(S.VAL(INTEGER, this.tag)) THEN + father := NIL; + LOOP + INC(S.VAL(INTEGER, this.tag)); + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + IF flag >= 2 THEN actual := this.first; this.actual := actual + ELSE actual := S.ADR(this.last) + END; + LOOP + offset := tag.ptroffs[0]; + IF offset < 0 THEN + INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) + IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) + INC(actual, tag.size); this.actual := actual + ELSE (* up *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + IF father = NIL THEN RETURN END; + son := this; this := father; + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + offset := tag.ptroffs[0]; + IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; + S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); + INC(S.VAL(INTEGER, tag), 4) + END + ELSE + S.GET(actual + offset, son); + IF son # NIL THEN + DEC(S.VAL(INTEGER, son), 4); + IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + S.PUT(actual + offset, father); father := this; this := son; + EXIT + END + END; + INC(S.VAL(INTEGER, tag), 4) + END + END + END + END + END Mark; + + PROCEDURE MarkGlobals; + VAR m: Module; i, p: INTEGER; + BEGIN + m := modList; + WHILE m # NIL DO + IF m.refcnt >= 0 THEN + i := 0; + WHILE i < m.nofptrs DO + S.GET(m.varBase + m.ptrs[i], p); INC(i); + IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END + END + END; + m := m.next + END + END MarkGlobals; + +(* This is the specification for the code procedure following below: + + PROCEDURE Next (b: Block): Block; (* next block in same cluster *) + VAR size: INTEGER; + BEGIN + S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); + IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; + RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) + END Next; + +*) + PROCEDURE [code] Next (b: Block): Block (* next block in same cluster *) + (* + MOV ECX,[EAX] b.tag + AND CL,0FCH b.tag DIV * 4 + MOV ECX,[ECX] size + TESTB [EAX],02H ODD(b.tag DIV 2) + JE L1 + ADD ECX,[EAX,4] size + b.last + SUB ECX,EAX + SUB ECX,4 size + b.last - ADR(b.last) + L1: + ADD ECX,19 size + 19 + AND CL,0F0H (size + 19) DIV 16 * 16 + ADD EAX,ECX b + size + *) + 08BH, 008H, + 080H, 0E1H, 0FCH, + 08BH, 009H, + 0F6H, 000H, 002H, + 074H, 008H, + 003H, 048H, 004H, + 029H, 0C1H, + 083H, 0E9H, 004H, + 083H, 0C1H, 013H, + 080H, 0E1H, 0F0H, + 001H, 0C8H; + + PROCEDURE CheckCandidates; + (* pre: nofcand > 0 *) + VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; + BEGIN + (* sort candidates (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; + REPEAT h := h DIV 3; i := h; + WHILE i < nofcand DO p := candidates[i]; j := i; + WHILE (j >= h) & (candidates[j-h] > p) DO + candidates[j] := candidates[j-h]; j := j-h + END; + candidates[j] := p; INC(i) + END + UNTIL h = 1; + (* sweep *) + c := root; i := 0; + WHILE c # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); + end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; + WHILE candidates[i] < S.VAL(INTEGER, blk) DO + INC(i); + IF i = nofcand THEN RETURN END + END; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF candidates[i] < S.VAL(INTEGER, next) THEN + IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) + & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN + Mark(blk) + END; + REPEAT + INC(i); + IF i = nofcand THEN RETURN END + UNTIL candidates[i] >= S.VAL(INTEGER, next) + END; + IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) + & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) + Mark(blk) + END; + blk := next + END; + c := c.next + END + END CheckCandidates; + + PROCEDURE MarkLocals; + VAR sp, p, min, max: INTEGER; c: Cluster; + BEGIN + S.GETREG(FP, sp); nofcand := 0; c := root; + WHILE c.next # NIL DO c := c.next END; + min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; + WHILE sp < baseStack DO + S.GET(sp, p); + IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN + candidates[nofcand] := p; INC(nofcand); + IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END + END; + INC(sp, 4) + END; + candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) + IF nofcand > 0 THEN CheckCandidates END + END MarkLocals; + + PROCEDURE MarkFinObj; + VAR f: FList; + BEGIN + wouldFinalize := FALSE; + f := finalizers; + WHILE f # NIL DO + IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END; + f := hotFinalizers; + WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END + END MarkFinObj; + + PROCEDURE CheckFinalizers; + VAR f, g, h, k: FList; + BEGIN + f := finalizers; g := NIL; + IF hotFinalizers = NIL THEN k := NIL + ELSE + k := hotFinalizers; + WHILE k.next # NIL DO k := k.next END + END; + WHILE f # NIL DO + h := f; f := f.next; + IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN + IF g = NIL THEN finalizers := f ELSE g.next := f END; + IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; + k := h; h.next := NIL + ELSE g := h + END + END; + h := hotFinalizers; + WHILE h # NIL DO Mark(h.blk); h := h.next END + END CheckFinalizers; + + PROCEDURE ExecFinalizer (a, b, c: INTEGER); + VAR f: FList; fin: PROCEDURE(this: ANYPTR); + BEGIN + f := S.VAL(FList, a); + IF f.aiptr THEN (* ArrFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) *) + ELSE + S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) + IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; +(* + IF f.iptr THEN RecFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) END +*) + END + END ExecFinalizer; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) + + PROCEDURE CallFinalizers; + VAR f: FList; + BEGIN + WHILE hotFinalizers # NIL DO + f := hotFinalizers; hotFinalizers := hotFinalizers.next; + Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) + END; + wouldFinalize := FALSE + END CallFinalizers; + + PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) + VAR i: INTEGER; + BEGIN + blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); + i := MIN(N - 1, (blk.size DIV 16)); + blk.next := free[i]; free[i] := blk + END Insert; + + PROCEDURE Sweep (dealloc: BOOLEAN); + VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; + BEGIN + cluster := root; last := NIL; allocated := 0; + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + WHILE cluster # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); + end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; + fblk := NIL; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF ODD(S.VAL(INTEGER, blk.tag)) THEN + IF fblk # NIL THEN + Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); + fblk := NIL + END; + DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) + INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) + ELSIF fblk = NIL THEN + fblk := S.VAL(FreeBlock, blk) + END; + blk := next + END; + IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) + c := cluster; cluster := cluster.next; + IF last = NIL THEN root := cluster ELSE last.next := cluster END; + FreeHeapMem(c) + ELSE + IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; + last := cluster; cluster := cluster.next + END + END; + (* reverse free list *) + i := N; + REPEAT + DEC(i); + b := free[i]; fblk := sentinel; + WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; + free[i] := fblk + UNTIL i = 0 + END Sweep; + + PROCEDURE Collect*; + BEGIN + IF root # NIL THEN + CallFinalizers; (* trap cleanup *) + IF debug & (watcher # NIL) THEN watcher(1) END; + MarkGlobals; + MarkLocals; + CheckFinalizers; + Sweep(TRUE); + CallFinalizers + END + END Collect; + + PROCEDURE FastCollect*; + BEGIN + IF root # NIL THEN + IF debug & (watcher # NIL) THEN watcher(2) END; + MarkGlobals; + MarkLocals; + MarkFinObj; + Sweep(FALSE) + END + END FastCollect; + + PROCEDURE WouldFinalize* (): BOOLEAN; + BEGIN + RETURN wouldFinalize + END WouldFinalize; + + (* --------------------- memory allocation (portable) -------------------- *) + + PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + IF debug & (watcher # NIL) THEN watcher(3) END; + s := size - 4; + i := MIN(N - 1, s DIV 16); + WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; + b := free[i]; l := NIL; + WHILE b.size < s DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + RETURN b + END OldBlock; + + PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := limit - 4; + i := 0; + REPEAT + b := free[i]; l := NIL; + WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + INC(i) + UNTIL (b # NIL) OR (i = N); + RETURN b + END LastBlock; + + PROCEDURE NewBlock (size: INTEGER): Block; + VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; + BEGIN + ASSERT(size>=0,20); + IF size >7FFFFFECH THEN RETURN NIL END; (*20120822 Marc*) + tsize := (size + 19) DIV 16 * 16; + b := OldBlock(tsize); (* 1) search for free block *) + IF b = NIL THEN + FastCollect; b := OldBlock(tsize); (* 2) collect *) + IF b = NIL THEN + Collect; b := OldBlock(tsize); (* 2a) fully collect *) + END; + IF b = NIL THEN + AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) + IF new # NIL THEN + IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN + new.next := root; root := new + ELSE + c := root; + WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; + new.next := c.next; c.next := new + END; + b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); + b.size := (new.size - 12) DIV 16 * 16 - 4 + ELSE + RETURN NIL (* 4) give up *) + END + END + END; + (* b # NIL *) + a := b.size + 4 - tsize; + IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; + IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; + INC(allocated, tsize); + RETURN S.VAL(Block, b) + END NewBlock; + + PROCEDURE Allocated* (): INTEGER; + BEGIN + RETURN allocated + END Allocated; + + PROCEDURE Used* (): INTEGER; + BEGIN + RETURN used + END Used; + + PROCEDURE Root* (): INTEGER; + BEGIN + RETURN S.VAL(INTEGER, root) + END Root; + + + (* -------------------- Trap Handling --------------------- *) + + PROCEDURE^ InitFpu; + + PROCEDURE Start* (code: Command); + BEGIN + restart := code; +(* + S.GETREG(SP, baseStack); (* save base stack *) +*) + res := Libc.sigsetjmp(loopContext, Libc.TRUE); + code() + END Start; + + PROCEDURE Quit* (exitCode: INTEGER); + VAR m: Module; term: Command; t: BOOLEAN; + res: INTEGER; + BEGIN + trapViewer := NIL; trapChecker := NIL; restart := NIL; + t := terminating; terminating := TRUE; m := modList; + WHILE m # NIL DO (* call terminators *) + IF ~static OR ~t THEN + term := m.term; m.term := NIL; + IF term # NIL THEN term() END + END; +(* + ReleaseIPtrs(m); +*) + m := m.next + END; + CallFinalizers; + hotFinalizers := finalizers; finalizers := NIL; + CallFinalizers; +(* + IF ~inDll THEN + RemoveExcp(excpPtr^); + WinApi.ExitProcess(exitCode) (* never returns *) + END +*) + + res := Libc.fflush(0); + Libc.exit(exitCode) + END Quit; + + PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); + VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; + BEGIN + title := "Error xy"; + title[6] := CHR(id DIV 10 + ORD("0")); + title[7] := CHR(id MOD 10 + ORD("0")); +(* + res := WinApi.MessageBoxW(0, str, title, {}); +*) + text := SHORT(str$); + res := MessageBox(title$, SHORT(str), {mbOk}); +(* + IF ~inDll THEN RemoveExcp(excpPtr^) END; +*) +(* + WinApi.ExitProcess(1) +*) + Libc.exit(1) + (* never returns *) + END FatalError; + + PROCEDURE DefaultTrapViewer; + VAR len, ref, end, x, a, b, c: INTEGER; mod: Module; + name: Name; out: ARRAY 1024 OF SHORTCHAR; + + PROCEDURE WriteString (s: ARRAY OF SHORTCHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + BEGIN + IF len + n < LEN(out) THEN + i := len + n - 1; + WHILE i >= len DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) + END; + INC(len, n) + END + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END + END WriteLn; + + BEGIN + len := 0; + IF err = 129 THEN WriteString("invalid with") + ELSIF err = 130 THEN WriteString("invalid case") + ELSIF err = 131 THEN WriteString("function without return") + ELSIF err = 132 THEN WriteString("type guard") + ELSIF err = 133 THEN WriteString("implied type guard") + ELSIF err = 134 THEN WriteString("value out of range") + ELSIF err = 135 THEN WriteString("index out of range") + ELSIF err = 136 THEN WriteString("string too long") + ELSIF err = 137 THEN WriteString("stack overflow") + ELSIF err = 138 THEN WriteString("integer overflow") + ELSIF err = 139 THEN WriteString("division by zero") + ELSIF err = 140 THEN WriteString("infinite real result") + ELSIF err = 141 THEN WriteString("real underflow") + ELSIF err = 142 THEN WriteString("real overflow") + ELSIF err = 143 THEN WriteString("undefined real result") + ELSIF err = 200 THEN WriteString("keyboard interrupt") + ELSIF err = 202 THEN WriteString("illegal instruction: "); + WriteHex(val, 4) + ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 205 THEN WriteString("illegal execution [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) + ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; + WriteString("trap #"); WriteHex(err, 3) + END; + a := pc; b := fp; c := 12; + REPEAT + WriteLn; WriteString("- "); + mod := 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 + WriteString(mod.name); ref := mod.refs; + REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end); + IF a < end THEN + WriteString("."); WriteString(name) + END + ELSE + WriteString("("); WriteString(mod.name); WriteString(")") + END; + WriteString(" ") + END; + WriteString("(pc="); WriteHex(a, 8); + WriteString(", fp="); WriteHex(b, 8); WriteString(")"); + IF (b >= sp) & (b < stack) THEN + S.GET(b+4, a); (* stacked pc *) + S.GET(b, b); (* dynamic link *) + DEC(c) + ELSE c := 0 + END + UNTIL c = 0; + out[len] := 0X; + x := MessageBox("BlackBox", out$, {mbOk}) + END DefaultTrapViewer; + + PROCEDURE TrapCleanup; + VAR t: TrapCleaner; + BEGIN + WHILE trapStack # NIL DO + t := trapStack; trapStack := trapStack.next; t.Cleanup + END; + IF (trapChecker # NIL) & (err # 128) THEN trapChecker END + END TrapCleanup; + + PROCEDURE SetTrapGuard* (on: BOOLEAN); + BEGIN + guarded := on + END SetTrapGuard; + + PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); + VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf; + BEGIN + oldContext := currentTryContext; + res := Libc.sigsetjmp(context, Libc.TRUE); + currentTryContext := S.ADR(context); + IF res = 0 THEN (* first time around *) + h(a, b, c); + ELSIF res = trapReturn THEN (* after a trap *) + ELSE + HALT(100) + END; + currentTryContext := oldContext; + END Try; + + (* -------------------- Initialization --------------------- *) + + PROCEDURE InitFpu; (* COMPILER DEPENDENT *) + (* could be eliminated, delayed for backward compatibility *) + VAR cw: SET; + BEGIN + FINIT; + FSTCW; + (* denorm, underflow, precision, zero div, overflow masked *) + (* invalid trapped *) + (* round to nearest, temp precision *) + cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9}; + FLDCW + END InitFpu; + + (* A. V. Shiryaev: Show extended trap information (OpenBSD) *) + PROCEDURE ShowTrap (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t); + + PROCEDURE WriteChar (c: SHORTCHAR); + VAR s: ARRAY [untagged] 2 OF SHORTCHAR; + BEGIN + s[0] := c; s[1] := 0X; + res := Libc.printf(s) + END WriteChar; + + PROCEDURE WriteString (s: ARRAY OF SHORTCHAR); + VAR res: INTEGER; + BEGIN + res := Libc.printf(s) + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + s: ARRAY 9 OF SHORTCHAR; + BEGIN + s[n] := 0X; + i := 0 + n - 1; + WriteChar("$"); + WHILE i >= 0 DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + s[i] := SHORT(CHR(y + ORD("0"))); + DEC(i) + END; + WriteString(s) + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + WriteChar(0AX) + END WriteLn; + + PROCEDURE KV (name: ARRAY OF SHORTCHAR; x: INTEGER); + BEGIN + WriteString(name); WriteString(" = "); WriteHex(x, 8) + END KV; + + BEGIN + WriteString("================================"); WriteLn; + WriteString("TRAP:"); WriteLn; + WriteString("--------------------------------"); WriteLn; + + KV("sig", sig); WriteString(", "); + KV("baseStack", baseStack); WriteLn; + + KV("GS ", context.sc_gs); WriteString(", "); + KV("FS ", context.sc_fs); WriteString(", "); + KV("ES ", context.sc_es); WriteString(", "); + KV("DS ", context.sc_ds); WriteLn; + + KV("EDI", context.sc_edi); WriteString(", "); + KV("ESI", context.sc_esi); WriteString(", "); + KV("EBP", context.sc_ebp); WriteString(", "); + KV("EBX", context.sc_ebx); WriteLn; + + KV("EDX", context.sc_edx); WriteString(", "); + KV("ECX", context.sc_ecx); WriteString(", "); + KV("EAX", context.sc_eax); WriteString(", "); + KV("EIP", context.sc_eip); WriteLn; + + KV("CS", context.sc_cs); WriteString(", "); + KV("EFLAGS", context.sc_eflags); WriteString(", "); + KV("ESP", context.sc_esp); WriteString(", "); + KV("SS", context.sc_ss); WriteLn; + + KV("ONSTACK", context.sc_onstack); WriteString(", "); + KV("MASK", context.sc_mask); WriteString(", "); + KV("TRAPNO", context.sc_trapno); WriteString(", "); + KV("ERR", context.sc_err); WriteLn; + + (* WriteString("--------------------------------"); WriteLn; *) + + (* TODO: show siginfo *) + + WriteString("================================"); WriteLn + END ShowTrap; + + PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t); + BEGIN + IF isReadableCheck THEN + isReadableCheck := FALSE; + Msg("~IsReadable"); + Libc.siglongjmp(isReadableContext, 1) + END; + + (* + S.GETREG(SP, sp); + S.GETREG(FP, fp); + *) + stack := baseStack; + + (* A. V. Shiryaev *) + (* + sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *) + fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *) + pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *) + *) + (* val := siginfo.si_addr; *) + (* OpenBSD *) + ShowTrap(sig, siginfo, context); + sp := context.sc_esp; fp := context.sc_ebp; pc := context.sc_eip; + val := siginfo.si_pid; (* XXX *) + + (* + Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno); + Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int); + *) + err := sig; + IF trapped THEN DefaultTrapViewer END; + CASE sig OF + Libc.SIGINT: + err := 200 (* Interrupt (ANSI). *) + | Libc.SIGILL: (* Illegal instruction (ANSI). *) + err := 202; val := 0; + IF IsReadable(pc, pc + 4) THEN + S.GET(pc, val); + IF val MOD 100H = 8DH THEN (* lea reg,reg *) + IF val DIV 100H MOD 100H = 0F0H THEN + err := val DIV 10000H MOD 100H (* trap *) + ELSIF val DIV 1000H MOD 10H = 0EH THEN + err := 128 + val DIV 100H MOD 10H (* run time error *) + END + END + END + | Libc.SIGFPE: + CASE siginfo.si_code OF + 0: (* TODO: ?????? *) + (* A. V. Shiryaev: OpenBSD *) + (* + IF siginfo.si_int = 8 THEN + err := 139 + ELSIF siginfo.si_int = 0 THEN + err := 143 + END + *) + err := 143; + | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *) + | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *) + | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *) + | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *) + | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *) + | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *) + | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *) + | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *) + ELSE + END + | Libc.SIGSEGV: (* Segmentation violation (ANSI). *) + err := 203 + ELSE + END; + INC(trapCount); + InitFpu; + TrapCleanup; + IF err # 128 THEN + IF (trapViewer = NIL) OR trapped THEN + DefaultTrapViewer + ELSE + trapped := TRUE; + + trapViewer(); + + trapped := FALSE + END + END; + IF currentTryContext # NIL THEN (* Try failed *) + Libc.siglongjmp(currentTryContext, trapReturn) + ELSE + IF restart # NIL THEN (* Start failed *) + Libc.siglongjmp(loopContext, trapReturn) + END; + Quit(1); (* FIXME *) + END; + trapped := FALSE + END TrapHandler; + + PROCEDURE InstallSignals*; + VAR sa, old: Libc.sigaction_t; res, i: INTEGER; +(* + sigstk: Libc.sigaltstack_t; + errno: INTEGER; +*) + BEGIN +(* + (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *) + sigstk.ss_sp := sigStack; + sigstk.ss_size := sigStackSize; + sigstk.ss_flags := 0; + res := Libc.sigaltstack(sigstk, NIL); + IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!"); + S.GET( Libc.__errno_location(), errno ); + Int(errno); + Libc.exit(1) + END; +*) + + sa.sa_sigaction := TrapHandler; +(* + res := LinLibc.sigemptyset(S.ADR(sa.sa_mask)); +*) + res := Libc.sigfillset(S.ADR(sa.sa_mask)); + sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *) + (* + IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END; + IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END; + IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END; + IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END; + IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END; + IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END; + *) + (* respond to all possible signals *) + FOR i := 1 TO Libc._NSIG - 1 DO + IF (i # Libc.SIGKILL) + & (i # Libc.SIGSTOP) + & (i # Libc.SIGWINCH) + & (i # Libc.SIGTHR) (* A. V. Shiryaev: OpenBSD -pthread *) + THEN + IF Libc.sigaction(i, sa, old) # 0 THEN Msg("failed to install signal"); Int(i) END; + END + END + END InstallSignals; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN +(* + (* for sigaltstack *) + sigStack := Libc.calloc(1, sigStackSize); + IF sigStack = Libc.NULL THEN + Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!"); + Libc.exit(1) + END; +*) + + isReadableCheck := FALSE; + + InstallSignals; (* init exception handling *) + currentTryContext := NIL; + + allocated := 0; total := 0; used := 0; + sentinelBlock.size := MAX(INTEGER); + sentinel := S.ADR(sentinelBlock); + +(* + S.PUTREG(ML, S.ADR(modList)); +*) + + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + + IF inDll THEN +(* + baseStack := FPageWord(4); (* begin of stack segment *) +*) + END; + InitFpu; + IF ~static THEN + InitModule(modList); + IF ~inDll THEN Quit(1) END + END; + told := 0; shift := 0 + END Init; + +BEGIN + IF modList = NIL THEN (* only once *) + S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *) + IF bootInfo # NIL THEN + modList := bootInfo.modList (* boot loader initializes the bootInfo struct *) + ELSE + S.GETREG(ML, modList) (* linker loads module list to BX *) + END; + static := init IN modList.opts; + inDll := dll IN modList.opts; + Init + END +CLOSE + IF ~terminating THEN + terminating := TRUE; + Quit(0) + END +END Kernel. diff --git a/Trurl-based/_OpenBSD_/dev0 b/Trurl-based/_OpenBSD_/dev0 new file mode 120000 index 0000000..b787eae --- /dev/null +++ b/Trurl-based/_OpenBSD_/dev0 @@ -0,0 +1 @@ +Lin/Rsrc/loader/dev0 \ No newline at end of file diff --git a/Trurl-based/_OpenBSD_/libBB.so b/Trurl-based/_OpenBSD_/libBB.so new file mode 100644 index 0000000..9872136 Binary files /dev/null and b/Trurl-based/_OpenBSD_/libBB.so differ diff --git a/Trurl-based/_OpenBSD_/libBB0.so b/Trurl-based/_OpenBSD_/libBB0.so new file mode 100644 index 0000000..36986e7 Binary files /dev/null and b/Trurl-based/_OpenBSD_/libBB0.so differ diff --git a/Trurl-based/_OpenBSD_/libdlobsdwrap.so b/Trurl-based/_OpenBSD_/libdlobsdwrap.so new file mode 120000 index 0000000..7c1e1bb --- /dev/null +++ b/Trurl-based/_OpenBSD_/libdlobsdwrap.so @@ -0,0 +1 @@ +Lin/Rsrc/loader/libdlobsdwrap.so \ No newline at end of file diff --git a/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GLib.odc b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GLib.odc new file mode 100644 index 0000000..2e103e3 Binary files /dev/null and b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GLib.odc differ diff --git a/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GObject.odc b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GObject.odc new file mode 100644 index 0000000..07f12c1 Binary files /dev/null and b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GObject.odc differ diff --git a/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gdk.odc b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gdk.odc new file mode 100644 index 0000000..aec7de5 Binary files /dev/null and b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gdk.odc differ diff --git a/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gtk.odc b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gtk.odc new file mode 100644 index 0000000..3feb18e Binary files /dev/null and b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gtk.odc differ diff --git a/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Pango.odc b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Pango.odc new file mode 100644 index 0000000..32f550e Binary files /dev/null and b/Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Pango.odc differ diff --git a/Trurl-based/_Windows_/BlackBox.exe b/Trurl-based/_Windows_/BlackBox.exe new file mode 100755 index 0000000..2e099e8 Binary files /dev/null and b/Trurl-based/_Windows_/BlackBox.exe differ diff --git a/Trurl-based/_Windows_/BlackBox.exe.manifest b/Trurl-based/_Windows_/BlackBox.exe.manifest new file mode 100644 index 0000000..e898101 --- /dev/null +++ b/Trurl-based/_Windows_/BlackBox.exe.manifest @@ -0,0 +1,18 @@ + + + + + + + + diff --git a/Trurl-based/_Windows_/Comm/Docu/TCP.odc b/Trurl-based/_Windows_/Comm/Docu/TCP.odc new file mode 100644 index 0000000..6ae0d1b Binary files /dev/null and b/Trurl-based/_Windows_/Comm/Docu/TCP.odc differ diff --git a/Trurl-based/_Windows_/Comm/Docu/V24.odc b/Trurl-based/_Windows_/Comm/Docu/V24.odc new file mode 100644 index 0000000..b13c2c1 Binary files /dev/null and b/Trurl-based/_Windows_/Comm/Docu/V24.odc differ diff --git a/Trurl-based/_Windows_/Comm/Mod/TCP.odc b/Trurl-based/_Windows_/Comm/Mod/TCP.odc new file mode 100644 index 0000000..e1e3b89 Binary files /dev/null and b/Trurl-based/_Windows_/Comm/Mod/TCP.odc differ diff --git a/Trurl-based/_Windows_/Comm/Mod/V24.odc b/Trurl-based/_Windows_/Comm/Mod/V24.odc new file mode 100644 index 0000000..99950fd Binary files /dev/null and b/Trurl-based/_Windows_/Comm/Mod/V24.odc differ diff --git a/Trurl-based/_Windows_/Host/Mod/Console.odc b/Trurl-based/_Windows_/Host/Mod/Console.odc new file mode 100644 index 0000000..ffd03b4 Binary files /dev/null and b/Trurl-based/_Windows_/Host/Mod/Console.odc differ diff --git a/Trurl-based/_Windows_/Host/Mod/Console.txt b/Trurl-based/_Windows_/Host/Mod/Console.txt new file mode 100644 index 0000000..81f0456 --- /dev/null +++ b/Trurl-based/_Windows_/Host/Mod/Console.txt @@ -0,0 +1,120 @@ +MODULE HostConsole; + + (* THIS IS TEXT COPY OF Console.odc *) + (* DO NOT EDIT *) + + (* + A. V. Shiryaev, 2012.10 + + Console implementation for Windows + *) + + IMPORT SYSTEM, Console, WinApi; + + TYPE + Cons = POINTER TO RECORD (Console.Console) END; + + CONST + inBufLen = 128; (* > 0 *) + + VAR + cons: Cons; + out, in: WinApi.HANDLE; + + ss: ARRAY 1024 OF SHORTCHAR; + + inBuf: ARRAY [untagged] inBufLen OF SHORTCHAR; + inBufW, inBufR: INTEGER; (* 0 <= inBufR <= inBufW <= inBufLen *) + + PROCEDURE (cons: Cons) ReadLn (OUT text: ARRAY OF CHAR); + VAR + W: INTEGER; + res: WinApi.BOOL; + i: INTEGER; + done: BOOLEAN; + res1: INTEGER; + BEGIN + (* ReadLine -> ss, W *) + W := 0; + done := FALSE; + REPEAT + i := inBufR; + WHILE (i < inBufW) & (inBuf[i] # 0AX) & (W < LEN(ss)) DO + ss[W] := inBuf[i]; + INC(W); + INC(i) + END; + IF i = inBufW THEN + inBufW := 0; inBufR := 0; + res := WinApi.ReadFile(in, SYSTEM.ADR(inBuf[0]), inBufLen, i, NIL); + IF res # 0 THEN (* TRUE *) + inBufW := i + ELSE + (* W := 0; *) done := TRUE + END + ELSIF inBuf[i] = 0AX THEN + ss[W] := 0AX; INC(W); done := TRUE; + inBufR := i + 1 + ELSE (* ss is too small *) + W := 0; done := TRUE + END + UNTIL done; + + IF W > 0 THEN + res1 := WinApi.MultiByteToWideChar(WinApi.CP_OEMCP, {}, ss, W, text, LEN(text) - 1); + IF (res1 > 0) & (res1 < LEN(text)) THEN + text[res1] := 0X + ELSE + text[0] := 0X + END + ELSE + text[0] := 0X + END + END ReadLn; + + PROCEDURE Print (IN s: ARRAY OF CHAR; len: INTEGER); + VAR res, written: INTEGER; + BEGIN + IF len > 0 THEN + res := WinApi.WideCharToMultiByte(WinApi.CP_OEMCP, {}, s, len, ss, LEN(ss), NIL, NIL); + IF (res > 0) & (res <= LEN(ss)) THEN + res := WinApi.WriteFile(out, SYSTEM.ADR(ss[0]), res, written, NIL) + END + END + END Print; + + PROCEDURE (cons: Cons) WriteChar (c: CHAR); + VAR ss: ARRAY 1 OF CHAR; + BEGIN + ss[0] := c; + Print(ss, 1) + END WriteChar; + + PROCEDURE (cons: Cons) WriteStr (IN text: ARRAY OF CHAR); + BEGIN + Print(text, LEN(text$)) + END WriteStr; + + PROCEDURE (cons: Cons) WriteLn; + BEGIN + Print(0DX + 0AX, 2) + END WriteLn; + + PROCEDURE Init; + VAR res: WinApi.BOOL; + BEGIN + NEW(cons); + + res := WinApi.AllocConsole(); (* Open console on module load time *) + + out := WinApi.GetStdHandle(WinApi.STD_OUTPUT_HANDLE); + in := WinApi.GetStdHandle(WinApi.STD_INPUT_HANDLE); + + inBufW := 0; inBufR := 0; + + Console.SetConsole(cons) + END Init; + +BEGIN + Init +END HostConsole. diff --git a/Trurl-based/_Windows_/Win/Docu/Api.odc b/Trurl-based/_Windows_/Win/Docu/Api.odc new file mode 100644 index 0000000..a24f9cd Binary files /dev/null and b/Trurl-based/_Windows_/Win/Docu/Api.odc differ diff --git a/Trurl-based/_Windows_/Win/Mod/Api.odc b/Trurl-based/_Windows_/Win/Mod/Api.odc new file mode 100644 index 0000000..b1f3010 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Mod/Api.odc differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Applogo.ico b/Trurl-based/_Windows_/Win/Rsrc/Applogo.ico new file mode 100644 index 0000000..42cba21 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Applogo.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/CFLogo.ico b/Trurl-based/_Windows_/Win/Rsrc/CFLogo.ico new file mode 100644 index 0000000..813da19 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/CFLogo.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Copy.cur b/Trurl-based/_Windows_/Win/Rsrc/Copy.cur new file mode 100644 index 0000000..c72daba Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Copy.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Doclogo.ico b/Trurl-based/_Windows_/Win/Rsrc/Doclogo.ico new file mode 100644 index 0000000..958e281 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Doclogo.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/DtyLogo.ico b/Trurl-based/_Windows_/Win/Rsrc/DtyLogo.ico new file mode 100644 index 0000000..f69b27c Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/DtyLogo.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Hand.cur b/Trurl-based/_Windows_/Win/Rsrc/Hand.cur new file mode 100644 index 0000000..24dbf27 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Hand.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Link.cur b/Trurl-based/_Windows_/Win/Rsrc/Link.cur new file mode 100644 index 0000000..d8f2725 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Link.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Move.cur b/Trurl-based/_Windows_/Win/Rsrc/Move.cur new file mode 100644 index 0000000..7cae8d1 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Move.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Pick.cur b/Trurl-based/_Windows_/Win/Rsrc/Pick.cur new file mode 100644 index 0000000..4398d0c Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Pick.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/SFLogo.ico b/Trurl-based/_Windows_/Win/Rsrc/SFLogo.ico new file mode 100644 index 0000000..72b09cc Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/SFLogo.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Stop.cur b/Trurl-based/_Windows_/Win/Rsrc/Stop.cur new file mode 100644 index 0000000..7e71e72 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Stop.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/Table.cur b/Trurl-based/_Windows_/Win/Rsrc/Table.cur new file mode 100644 index 0000000..d96cd5f Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/Table.cur differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/folderimg.ico b/Trurl-based/_Windows_/Win/Rsrc/folderimg.ico new file mode 100644 index 0000000..3134a7f Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/folderimg.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/leafimg.ico b/Trurl-based/_Windows_/Win/Rsrc/leafimg.ico new file mode 100644 index 0000000..34584d5 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/leafimg.ico differ diff --git a/Trurl-based/_Windows_/Win/Rsrc/openimg.ico b/Trurl-based/_Windows_/Win/Rsrc/openimg.ico new file mode 100644 index 0000000..96d71e3 Binary files /dev/null and b/Trurl-based/_Windows_/Win/Rsrc/openimg.ico differ diff --git a/Trurl-based/_Windows_/dev0.exe b/Trurl-based/_Windows_/dev0.exe new file mode 100644 index 0000000..d16eecb Binary files /dev/null and b/Trurl-based/_Windows_/dev0.exe differ diff --git a/Trurl-based/__GUI/Comm/Docu/ObxStreamsClient.odc b/Trurl-based/__GUI/Comm/Docu/ObxStreamsClient.odc new file mode 100644 index 0000000..5767991 Binary files /dev/null and b/Trurl-based/__GUI/Comm/Docu/ObxStreamsClient.odc differ diff --git a/Trurl-based/__GUI/Comm/Docu/ObxStreamsServer.odc b/Trurl-based/__GUI/Comm/Docu/ObxStreamsServer.odc new file mode 100644 index 0000000..e3f2fa1 Binary files /dev/null and b/Trurl-based/__GUI/Comm/Docu/ObxStreamsServer.odc differ diff --git a/Trurl-based/__GUI/Comm/Docu/Sys-Map.odc b/Trurl-based/__GUI/Comm/Docu/Sys-Map.odc new file mode 100644 index 0000000..e8c0043 Binary files /dev/null and b/Trurl-based/__GUI/Comm/Docu/Sys-Map.odc differ diff --git a/Trurl-based/__GUI/Comm/Mod/ObxStreamsClient.odc b/Trurl-based/__GUI/Comm/Mod/ObxStreamsClient.odc new file mode 100644 index 0000000..76ec4c5 Binary files /dev/null and b/Trurl-based/__GUI/Comm/Mod/ObxStreamsClient.odc differ diff --git a/Trurl-based/__GUI/Comm/Mod/ObxStreamsServer.odc b/Trurl-based/__GUI/Comm/Mod/ObxStreamsServer.odc new file mode 100644 index 0000000..1bddc9c Binary files /dev/null and b/Trurl-based/__GUI/Comm/Mod/ObxStreamsServer.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/AlienTool.odc b/Trurl-based/__GUI/Dev/Mod/AlienTool.odc new file mode 100644 index 0000000..f1612db Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/AlienTool.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Analyzer.odc b/Trurl-based/__GUI/Dev/Mod/Analyzer.odc new file mode 100644 index 0000000..1921e1c Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Analyzer.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Browser.odc b/Trurl-based/__GUI/Dev/Mod/Browser.odc new file mode 100644 index 0000000..4fb3308 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Browser.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Cmds.odc b/Trurl-based/__GUI/Dev/Mod/Cmds.odc new file mode 100644 index 0000000..d76496f Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Cmds.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Debug.odc b/Trurl-based/__GUI/Dev/Mod/Debug.odc new file mode 100644 index 0000000..6adaa63 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Debug.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Dependencies.odc b/Trurl-based/__GUI/Dev/Mod/Dependencies.odc new file mode 100644 index 0000000..97087bb Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Dependencies.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/HeapSpy.odc b/Trurl-based/__GUI/Dev/Mod/HeapSpy.odc new file mode 100644 index 0000000..6436929 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/HeapSpy.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Inspector.odc b/Trurl-based/__GUI/Dev/Mod/Inspector.odc new file mode 100644 index 0000000..656119b Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Inspector.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/LinkChk.odc b/Trurl-based/__GUI/Dev/Mod/LinkChk.odc new file mode 100644 index 0000000..bd0d814 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/LinkChk.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/MsgSpy.odc b/Trurl-based/__GUI/Dev/Mod/MsgSpy.odc new file mode 100644 index 0000000..172571c Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/MsgSpy.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/RBrowser.odc b/Trurl-based/__GUI/Dev/Mod/RBrowser.odc new file mode 100644 index 0000000..de01661 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/RBrowser.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/References.odc b/Trurl-based/__GUI/Dev/Mod/References.odc new file mode 100644 index 0000000..158d0f9 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/References.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/Search.odc b/Trurl-based/__GUI/Dev/Mod/Search.odc new file mode 100644 index 0000000..e831644 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/Search.odc differ diff --git a/Trurl-based/__GUI/Dev/Mod/SubTool.odc b/Trurl-based/__GUI/Dev/Mod/SubTool.odc new file mode 100644 index 0000000..695c630 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Mod/SubTool.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/AnaOpt.opt b/Trurl-based/__GUI/Dev/Rsrc/AnaOpt.opt new file mode 100644 index 0000000..ae1b13f Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/AnaOpt.opt differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/Analyzer.odc b/Trurl-based/__GUI/Dev/Rsrc/Analyzer.odc new file mode 100644 index 0000000..2aaef81 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/Analyzer.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/BrowOpt.opt b/Trurl-based/__GUI/Dev/Rsrc/BrowOpt.opt new file mode 100644 index 0000000..e7d1ed7 --- /dev/null +++ b/Trurl-based/__GUI/Dev/Rsrc/BrowOpt.opt @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/Trurl-based/__GUI/Dev/Rsrc/Browser.odc b/Trurl-based/__GUI/Dev/Rsrc/Browser.odc new file mode 100644 index 0000000..7ee9b7d Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/Browser.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/ComInterfaceGen.odc b/Trurl-based/__GUI/Dev/Rsrc/ComInterfaceGen.odc new file mode 100644 index 0000000..e6b34a8 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/ComInterfaceGen.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/Create.odc b/Trurl-based/__GUI/Dev/Rsrc/Create.odc new file mode 100644 index 0000000..cfefe6c Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/Create.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/HeapSpy.odc b/Trurl-based/__GUI/Dev/Rsrc/HeapSpy.odc new file mode 100644 index 0000000..e223a21 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/HeapSpy.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/Inspect.odc b/Trurl-based/__GUI/Dev/Rsrc/Inspect.odc new file mode 100644 index 0000000..8dd0ad3 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/Inspect.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/LinkChk.odc b/Trurl-based/__GUI/Dev/Rsrc/LinkChk.odc new file mode 100644 index 0000000..717b40f Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/LinkChk.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/Menus.odc b/Trurl-based/__GUI/Dev/Rsrc/Menus.odc new file mode 100644 index 0000000..7072dbe Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/Menus.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/MsgSpy.odc b/Trurl-based/__GUI/Dev/Rsrc/MsgSpy.odc new file mode 100644 index 0000000..408fcda Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/MsgSpy.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Cmds0.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds0.odc new file mode 100644 index 0000000..279a19d Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds0.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Cmds1.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds1.odc new file mode 100644 index 0000000..5d1f35f Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds1.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Cmds5.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds5.odc new file mode 100644 index 0000000..87168a7 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Cmds5.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Models5.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Models5.odc new file mode 100644 index 0000000..e34f05b Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Models5.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Views3.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Views3.odc new file mode 100644 index 0000000..2548f7b Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Views3.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Views4.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Views4.odc new file mode 100644 index 0000000..99df544 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Views4.odc differ diff --git a/Trurl-based/__GUI/Dev/Rsrc/New/Views5.odc b/Trurl-based/__GUI/Dev/Rsrc/New/Views5.odc new file mode 100644 index 0000000..ee685b1 Binary files /dev/null and b/Trurl-based/__GUI/Dev/Rsrc/New/Views5.odc differ diff --git a/Trurl-based/__GUI/Empty.odc b/Trurl-based/__GUI/Empty.odc new file mode 100644 index 0000000..8808acb Binary files /dev/null and b/Trurl-based/__GUI/Empty.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Cmds.odc b/Trurl-based/__GUI/Form/Docu/Cmds.odc new file mode 100644 index 0000000..6722a11 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Cmds.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Controllers.odc b/Trurl-based/__GUI/Form/Docu/Controllers.odc new file mode 100644 index 0000000..aff7459 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Controllers.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Dev-Man.odc b/Trurl-based/__GUI/Form/Docu/Dev-Man.odc new file mode 100644 index 0000000..5b619eb Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Dev-Man.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Gen.odc b/Trurl-based/__GUI/Form/Docu/Gen.odc new file mode 100644 index 0000000..659eb0e Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Gen.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Models.odc b/Trurl-based/__GUI/Form/Docu/Models.odc new file mode 100644 index 0000000..4099566 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Models.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Sys-Map.odc b/Trurl-based/__GUI/Form/Docu/Sys-Map.odc new file mode 100644 index 0000000..e6aca90 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Sys-Map.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/User-Man.odc b/Trurl-based/__GUI/Form/Docu/User-Man.odc new file mode 100644 index 0000000..a1e96b3 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/User-Man.odc differ diff --git a/Trurl-based/__GUI/Form/Docu/Views.odc b/Trurl-based/__GUI/Form/Docu/Views.odc new file mode 100644 index 0000000..3901ac4 Binary files /dev/null and b/Trurl-based/__GUI/Form/Docu/Views.odc differ diff --git a/Trurl-based/__GUI/Form/Mod/Cmds.odc b/Trurl-based/__GUI/Form/Mod/Cmds.odc new file mode 100644 index 0000000..6891494 Binary files /dev/null and b/Trurl-based/__GUI/Form/Mod/Cmds.odc differ diff --git a/Trurl-based/__GUI/Form/Mod/Controllers.odc b/Trurl-based/__GUI/Form/Mod/Controllers.odc new file mode 100644 index 0000000..2f948ac Binary files /dev/null and b/Trurl-based/__GUI/Form/Mod/Controllers.odc differ diff --git a/Trurl-based/__GUI/Form/Mod/Gen.odc b/Trurl-based/__GUI/Form/Mod/Gen.odc new file mode 100644 index 0000000..afb063f Binary files /dev/null and b/Trurl-based/__GUI/Form/Mod/Gen.odc differ diff --git a/Trurl-based/__GUI/Form/Mod/Models.odc b/Trurl-based/__GUI/Form/Mod/Models.odc new file mode 100644 index 0000000..2faa5bd Binary files /dev/null and b/Trurl-based/__GUI/Form/Mod/Models.odc differ diff --git a/Trurl-based/__GUI/Form/Mod/Views.odc b/Trurl-based/__GUI/Form/Mod/Views.odc new file mode 100644 index 0000000..4f58ff5 Binary files /dev/null and b/Trurl-based/__GUI/Form/Mod/Views.odc differ diff --git a/Trurl-based/__GUI/Form/Rsrc/Cmds.odc b/Trurl-based/__GUI/Form/Rsrc/Cmds.odc new file mode 100644 index 0000000..48a3f50 Binary files /dev/null and b/Trurl-based/__GUI/Form/Rsrc/Cmds.odc differ diff --git a/Trurl-based/__GUI/Form/Rsrc/Cmds2.odc b/Trurl-based/__GUI/Form/Rsrc/Cmds2.odc new file mode 100644 index 0000000..f2f58d8 Binary files /dev/null and b/Trurl-based/__GUI/Form/Rsrc/Cmds2.odc differ diff --git a/Trurl-based/__GUI/Form/Rsrc/Gen.odc b/Trurl-based/__GUI/Form/Rsrc/Gen.odc new file mode 100644 index 0000000..f1b82bb Binary files /dev/null and b/Trurl-based/__GUI/Form/Rsrc/Gen.odc differ diff --git a/Trurl-based/__GUI/Form/Rsrc/Menus.odc b/Trurl-based/__GUI/Form/Rsrc/Menus.odc new file mode 100644 index 0000000..f551d19 Binary files /dev/null and b/Trurl-based/__GUI/Form/Rsrc/Menus.odc differ diff --git a/Trurl-based/__GUI/Form/Rsrc/Strings.odc b/Trurl-based/__GUI/Form/Rsrc/Strings.odc new file mode 100644 index 0000000..bacc83b Binary files /dev/null and b/Trurl-based/__GUI/Form/Rsrc/Strings.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/Imptype.odc b/Trurl-based/__GUI/Host/Rsrc/Imptype.odc new file mode 100644 index 0000000..efc1eab Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/Imptype.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/Prefs.odc b/Trurl-based/__GUI/Host/Rsrc/Prefs.odc new file mode 100644 index 0000000..dbe827a Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/Prefs.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/Printing.odc b/Trurl-based/__GUI/Host/Rsrc/Printing.odc new file mode 100644 index 0000000..6b17aca Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/Printing.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/Setup.odc b/Trurl-based/__GUI/Host/Rsrc/Setup.odc new file mode 100644 index 0000000..454a525 Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/Setup.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/Strings.odc b/Trurl-based/__GUI/Host/Rsrc/Strings.odc new file mode 100644 index 0000000..5a338f8 Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/Strings.odc differ diff --git a/Trurl-based/__GUI/Host/Rsrc/ru/Strings.odc b/Trurl-based/__GUI/Host/Rsrc/ru/Strings.odc new file mode 100644 index 0000000..fcbc2fa Binary files /dev/null and b/Trurl-based/__GUI/Host/Rsrc/ru/Strings.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Actions.odc b/Trurl-based/__GUI/Obx/Docu/Actions.odc new file mode 100644 index 0000000..cdcfe1d Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Actions.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Address0.odc b/Trurl-based/__GUI/Obx/Docu/Address0.odc new file mode 100644 index 0000000..fbe59f8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Address0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Address1.odc b/Trurl-based/__GUI/Obx/Docu/Address1.odc new file mode 100644 index 0000000..bcb684a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Address1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Address2.odc b/Trurl-based/__GUI/Obx/Docu/Address2.odc new file mode 100644 index 0000000..27e8334 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Address2.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Ascii.odc b/Trurl-based/__GUI/Obx/Docu/Ascii.odc new file mode 100644 index 0000000..979954e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Ascii.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/BB-Rules.odc b/Trurl-based/__GUI/Obx/Docu/BB-Rules.odc new file mode 100644 index 0000000..f20a7aa Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/BB-Rules.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/BlackBox.odc b/Trurl-based/__GUI/Obx/Docu/BlackBox.odc new file mode 100644 index 0000000..d9d6dd5 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/BlackBox.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Buttons.odc b/Trurl-based/__GUI/Obx/Docu/Buttons.odc new file mode 100644 index 0000000..fb08876 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Buttons.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Calc.odc b/Trurl-based/__GUI/Obx/Docu/Calc.odc new file mode 100644 index 0000000..26da622 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Calc.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Caps.odc b/Trurl-based/__GUI/Obx/Docu/Caps.odc new file mode 100644 index 0000000..7ee6bc9 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Caps.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/ContIter.odc b/Trurl-based/__GUI/Obx/Docu/ContIter.odc new file mode 100644 index 0000000..5476807 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/ContIter.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/ControlShifter.odc b/Trurl-based/__GUI/Obx/Docu/ControlShifter.odc new file mode 100644 index 0000000..b23ea80 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/ControlShifter.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Controls.odc b/Trurl-based/__GUI/Obx/Docu/Controls.odc new file mode 100644 index 0000000..a3fd85a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Controls.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Conv.odc b/Trurl-based/__GUI/Obx/Docu/Conv.odc new file mode 100644 index 0000000..0e44cc5 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Conv.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Count0.odc b/Trurl-based/__GUI/Obx/Docu/Count0.odc new file mode 100644 index 0000000..b780d8e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Count0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Count1.odc b/Trurl-based/__GUI/Obx/Docu/Count1.odc new file mode 100644 index 0000000..2921a70 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Count1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Ctrls.odc b/Trurl-based/__GUI/Obx/Docu/Ctrls.odc new file mode 100644 index 0000000..2694a2a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Ctrls.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Cubes.odc b/Trurl-based/__GUI/Obx/Docu/Cubes.odc new file mode 100644 index 0000000..5f69a37 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Cubes.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Db.odc b/Trurl-based/__GUI/Obx/Docu/Db.odc new file mode 100644 index 0000000..51507a2 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Db.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Dialog.odc b/Trurl-based/__GUI/Obx/Docu/Dialog.odc new file mode 100644 index 0000000..cfec6b2 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Dialog.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Fact.odc b/Trurl-based/__GUI/Obx/Docu/Fact.odc new file mode 100644 index 0000000..7bc0cb7 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Fact.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/FileTree.odc b/Trurl-based/__GUI/Obx/Docu/FileTree.odc new file mode 100644 index 0000000..68f4b88 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/FileTree.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/FldCtrls.odc b/Trurl-based/__GUI/Obx/Docu/FldCtrls.odc new file mode 100644 index 0000000..badee98 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/FldCtrls.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Graphs.odc b/Trurl-based/__GUI/Obx/Docu/Graphs.odc new file mode 100644 index 0000000..96b8a42 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Graphs.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Hello0.odc b/Trurl-based/__GUI/Obx/Docu/Hello0.odc new file mode 100644 index 0000000..d0b97f1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Hello0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Hello1.odc b/Trurl-based/__GUI/Obx/Docu/Hello1.odc new file mode 100644 index 0000000..065516a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Hello1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/LabelLister.odc b/Trurl-based/__GUI/Obx/Docu/LabelLister.odc new file mode 100644 index 0000000..83f58ed Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/LabelLister.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Lines.odc b/Trurl-based/__GUI/Obx/Docu/Lines.odc new file mode 100644 index 0000000..74c9565 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Lines.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Links.odc b/Trurl-based/__GUI/Obx/Docu/Links.odc new file mode 100644 index 0000000..81d8176 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Links.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Lookup0.odc b/Trurl-based/__GUI/Obx/Docu/Lookup0.odc new file mode 100644 index 0000000..9f3e718 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Lookup0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Lookup1.odc b/Trurl-based/__GUI/Obx/Docu/Lookup1.odc new file mode 100644 index 0000000..c4bccfe Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Lookup1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/MMerge.odc b/Trurl-based/__GUI/Obx/Docu/MMerge.odc new file mode 100644 index 0000000..0eafa7f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/MMerge.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Omosi.odc b/Trurl-based/__GUI/Obx/Docu/Omosi.odc new file mode 100644 index 0000000..d6cd26a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Omosi.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Open0.odc b/Trurl-based/__GUI/Obx/Docu/Open0.odc new file mode 100644 index 0000000..d218006 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Open0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Open1.odc b/Trurl-based/__GUI/Obx/Docu/Open1.odc new file mode 100644 index 0000000..49b0155 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Open1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Orders.odc b/Trurl-based/__GUI/Obx/Docu/Orders.odc new file mode 100644 index 0000000..3e1856a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Orders.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PDBRep0.odc b/Trurl-based/__GUI/Obx/Docu/PDBRep0.odc new file mode 100644 index 0000000..b2dea74 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PDBRep0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PDBRep1.odc b/Trurl-based/__GUI/Obx/Docu/PDBRep1.odc new file mode 100644 index 0000000..b689d77 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PDBRep1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PDBRep2.odc b/Trurl-based/__GUI/Obx/Docu/PDBRep2.odc new file mode 100644 index 0000000..c421741 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PDBRep2.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PDBRep3.odc b/Trurl-based/__GUI/Obx/Docu/PDBRep3.odc new file mode 100644 index 0000000..59084ff Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PDBRep3.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PDBRep4.odc b/Trurl-based/__GUI/Obx/Docu/PDBRep4.odc new file mode 100644 index 0000000..d460d1a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PDBRep4.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/ParCmd.odc b/Trurl-based/__GUI/Obx/Docu/ParCmd.odc new file mode 100644 index 0000000..b9c312b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/ParCmd.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Patterns.odc b/Trurl-based/__GUI/Obx/Docu/Patterns.odc new file mode 100644 index 0000000..5971c53 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Patterns.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PhoneDB.odc b/Trurl-based/__GUI/Obx/Docu/PhoneDB.odc new file mode 100644 index 0000000..2206c6a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PhoneDB.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PhoneUI.odc b/Trurl-based/__GUI/Obx/Docu/PhoneUI.odc new file mode 100644 index 0000000..0bcfdd0 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PhoneUI.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/PhoneUI1.odc b/Trurl-based/__GUI/Obx/Docu/PhoneUI1.odc new file mode 100644 index 0000000..7b0964d Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/PhoneUI1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Pi.odc b/Trurl-based/__GUI/Obx/Docu/Pi.odc new file mode 100644 index 0000000..e1599d1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Pi.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Random.odc b/Trurl-based/__GUI/Obx/Docu/Random.odc new file mode 100644 index 0000000..acffb22 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Random.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/RatCalc.odc b/Trurl-based/__GUI/Obx/Docu/RatCalc.odc new file mode 100644 index 0000000..b00323f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/RatCalc.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Sample.odc b/Trurl-based/__GUI/Obx/Docu/Sample.odc new file mode 100644 index 0000000..7e2eea6 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Sample.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Scroll.odc b/Trurl-based/__GUI/Obx/Docu/Scroll.odc new file mode 100644 index 0000000..039aa7b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Scroll.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Stores.odc b/Trurl-based/__GUI/Obx/Docu/Stores.odc new file mode 100644 index 0000000..bf56d3b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Stores.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Sys-Map.odc b/Trurl-based/__GUI/Obx/Docu/Sys-Map.odc new file mode 100644 index 0000000..7ed2ff0 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Sys-Map.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/TabViews.odc b/Trurl-based/__GUI/Obx/Docu/TabViews.odc new file mode 100644 index 0000000..1ce12f4 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/TabViews.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Tabs.odc b/Trurl-based/__GUI/Obx/Docu/Tabs.odc new file mode 100644 index 0000000..1dc66a5 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Tabs.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Tickers.odc b/Trurl-based/__GUI/Obx/Docu/Tickers.odc new file mode 100644 index 0000000..7f4d591 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Tickers.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Trap.odc b/Trurl-based/__GUI/Obx/Docu/Trap.odc new file mode 100644 index 0000000..aae4208 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Trap.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Twins.odc b/Trurl-based/__GUI/Obx/Docu/Twins.odc new file mode 100644 index 0000000..366db59 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Twins.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/UnitConv.odc b/Trurl-based/__GUI/Obx/Docu/UnitConv.odc new file mode 100644 index 0000000..7b9ae0c Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/UnitConv.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views0.odc b/Trurl-based/__GUI/Obx/Docu/Views0.odc new file mode 100644 index 0000000..21e409b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views0.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views1.odc b/Trurl-based/__GUI/Obx/Docu/Views1.odc new file mode 100644 index 0000000..96b31a4 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views1.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views10.odc b/Trurl-based/__GUI/Obx/Docu/Views10.odc new file mode 100644 index 0000000..8154f9e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views10.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views11.odc b/Trurl-based/__GUI/Obx/Docu/Views11.odc new file mode 100644 index 0000000..592aec5 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views11.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views12.odc b/Trurl-based/__GUI/Obx/Docu/Views12.odc new file mode 100644 index 0000000..f4064aa Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views12.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views13.odc b/Trurl-based/__GUI/Obx/Docu/Views13.odc new file mode 100644 index 0000000..ebdb15f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views13.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views14.odc b/Trurl-based/__GUI/Obx/Docu/Views14.odc new file mode 100644 index 0000000..1007f0a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views14.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views2.odc b/Trurl-based/__GUI/Obx/Docu/Views2.odc new file mode 100644 index 0000000..6fd7b4f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views2.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views3.odc b/Trurl-based/__GUI/Obx/Docu/Views3.odc new file mode 100644 index 0000000..26abd03 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views3.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views4.odc b/Trurl-based/__GUI/Obx/Docu/Views4.odc new file mode 100644 index 0000000..948edff Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views4.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views5.odc b/Trurl-based/__GUI/Obx/Docu/Views5.odc new file mode 100644 index 0000000..bb6657b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views5.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Views6.odc b/Trurl-based/__GUI/Obx/Docu/Views6.odc new file mode 100644 index 0000000..a7a141e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Views6.odc differ diff --git a/Trurl-based/__GUI/Obx/Docu/Wrappers.odc b/Trurl-based/__GUI/Obx/Docu/Wrappers.odc new file mode 100644 index 0000000..2695ece Binary files /dev/null and b/Trurl-based/__GUI/Obx/Docu/Wrappers.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Actions.odc b/Trurl-based/__GUI/Obx/Mod/Actions.odc new file mode 100644 index 0000000..f49e785 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Actions.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Address0.odc b/Trurl-based/__GUI/Obx/Mod/Address0.odc new file mode 100644 index 0000000..c31d45f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Address0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Address1.odc b/Trurl-based/__GUI/Obx/Mod/Address1.odc new file mode 100644 index 0000000..809c1bc Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Address1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Address2.odc b/Trurl-based/__GUI/Obx/Mod/Address2.odc new file mode 100644 index 0000000..2fff2d8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Address2.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Ascii.odc b/Trurl-based/__GUI/Obx/Mod/Ascii.odc new file mode 100644 index 0000000..3d3bd71 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Ascii.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/BlackBox.odc b/Trurl-based/__GUI/Obx/Mod/BlackBox.odc new file mode 100644 index 0000000..0ad7feb Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/BlackBox.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Buttons.odc b/Trurl-based/__GUI/Obx/Mod/Buttons.odc new file mode 100644 index 0000000..8e9c720 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Buttons.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Calc.odc b/Trurl-based/__GUI/Obx/Mod/Calc.odc new file mode 100644 index 0000000..234b4d2 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Calc.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Caps.odc b/Trurl-based/__GUI/Obx/Mod/Caps.odc new file mode 100644 index 0000000..475da1a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Caps.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/ContIter.odc b/Trurl-based/__GUI/Obx/Mod/ContIter.odc new file mode 100644 index 0000000..9bc72c8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/ContIter.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/ControlShifter.odc b/Trurl-based/__GUI/Obx/Mod/ControlShifter.odc new file mode 100644 index 0000000..93872c8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/ControlShifter.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Controls.odc b/Trurl-based/__GUI/Obx/Mod/Controls.odc new file mode 100644 index 0000000..3ebfd6f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Controls.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Conv.odc b/Trurl-based/__GUI/Obx/Mod/Conv.odc new file mode 100644 index 0000000..3e15ede Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Conv.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Count0.odc b/Trurl-based/__GUI/Obx/Mod/Count0.odc new file mode 100644 index 0000000..efb728b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Count0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Count1.odc b/Trurl-based/__GUI/Obx/Mod/Count1.odc new file mode 100644 index 0000000..1c88003 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Count1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Ctrls.odc b/Trurl-based/__GUI/Obx/Mod/Ctrls.odc new file mode 100644 index 0000000..f024f3a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Ctrls.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Cubes.odc b/Trurl-based/__GUI/Obx/Mod/Cubes.odc new file mode 100644 index 0000000..8935481 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Cubes.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Db.odc b/Trurl-based/__GUI/Obx/Mod/Db.odc new file mode 100644 index 0000000..63dfd62 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Db.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Dialog.odc b/Trurl-based/__GUI/Obx/Mod/Dialog.odc new file mode 100644 index 0000000..b449783 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Dialog.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Fact.odc b/Trurl-based/__GUI/Obx/Mod/Fact.odc new file mode 100644 index 0000000..61d3cb9 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Fact.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/FileTree.odc b/Trurl-based/__GUI/Obx/Mod/FileTree.odc new file mode 100644 index 0000000..20c2a83 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/FileTree.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/FldCtrls.odc b/Trurl-based/__GUI/Obx/Mod/FldCtrls.odc new file mode 100644 index 0000000..c73853e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/FldCtrls.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Graphs.odc b/Trurl-based/__GUI/Obx/Mod/Graphs.odc new file mode 100644 index 0000000..5fc5932 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Graphs.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Hello1.odc b/Trurl-based/__GUI/Obx/Mod/Hello1.odc new file mode 100644 index 0000000..15646cf Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Hello1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/LabelLister.odc b/Trurl-based/__GUI/Obx/Mod/LabelLister.odc new file mode 100644 index 0000000..9f09b62 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/LabelLister.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Lines.odc b/Trurl-based/__GUI/Obx/Mod/Lines.odc new file mode 100644 index 0000000..5caa8a3 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Lines.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Links.odc b/Trurl-based/__GUI/Obx/Mod/Links.odc new file mode 100644 index 0000000..939b560 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Links.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Lookup0.odc b/Trurl-based/__GUI/Obx/Mod/Lookup0.odc new file mode 100644 index 0000000..a5caddb Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Lookup0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Lookup1.odc b/Trurl-based/__GUI/Obx/Mod/Lookup1.odc new file mode 100644 index 0000000..7df1d18 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Lookup1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/MMerge.odc b/Trurl-based/__GUI/Obx/Mod/MMerge.odc new file mode 100644 index 0000000..31ec4e6 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/MMerge.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Omosi.odc b/Trurl-based/__GUI/Obx/Mod/Omosi.odc new file mode 100644 index 0000000..780dbba Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Omosi.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Open0.odc b/Trurl-based/__GUI/Obx/Mod/Open0.odc new file mode 100644 index 0000000..a8dde94 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Open0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Open1.odc b/Trurl-based/__GUI/Obx/Mod/Open1.odc new file mode 100644 index 0000000..5cc304e Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Open1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Orders.odc b/Trurl-based/__GUI/Obx/Mod/Orders.odc new file mode 100644 index 0000000..a3c8165 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Orders.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PDBRep0.odc b/Trurl-based/__GUI/Obx/Mod/PDBRep0.odc new file mode 100644 index 0000000..fda2bd3 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PDBRep0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PDBRep1.odc b/Trurl-based/__GUI/Obx/Mod/PDBRep1.odc new file mode 100644 index 0000000..628bca7 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PDBRep1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PDBRep2.odc b/Trurl-based/__GUI/Obx/Mod/PDBRep2.odc new file mode 100644 index 0000000..6e12995 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PDBRep2.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PDBRep3.odc b/Trurl-based/__GUI/Obx/Mod/PDBRep3.odc new file mode 100644 index 0000000..9f7b963 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PDBRep3.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PDBRep4.odc b/Trurl-based/__GUI/Obx/Mod/PDBRep4.odc new file mode 100644 index 0000000..27360d1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PDBRep4.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/ParCmd.odc b/Trurl-based/__GUI/Obx/Mod/ParCmd.odc new file mode 100644 index 0000000..6ca6638 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/ParCmd.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Patterns.odc b/Trurl-based/__GUI/Obx/Mod/Patterns.odc new file mode 100644 index 0000000..be229fe Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Patterns.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PhoneDB.odc b/Trurl-based/__GUI/Obx/Mod/PhoneDB.odc new file mode 100644 index 0000000..bbd04f5 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PhoneDB.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PhoneUI.odc b/Trurl-based/__GUI/Obx/Mod/PhoneUI.odc new file mode 100644 index 0000000..3d2a3d0 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PhoneUI.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/PhoneUI1.odc b/Trurl-based/__GUI/Obx/Mod/PhoneUI1.odc new file mode 100644 index 0000000..9f0a846 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/PhoneUI1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Ratcalc.odc b/Trurl-based/__GUI/Obx/Mod/Ratcalc.odc new file mode 100644 index 0000000..af71745 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Ratcalc.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Sample.odc b/Trurl-based/__GUI/Obx/Mod/Sample.odc new file mode 100644 index 0000000..391ca81 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Sample.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Scroll.odc b/Trurl-based/__GUI/Obx/Mod/Scroll.odc new file mode 100644 index 0000000..97d8760 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Scroll.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Stores.odc b/Trurl-based/__GUI/Obx/Mod/Stores.odc new file mode 100644 index 0000000..31f7f49 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Stores.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/TabViews.odc b/Trurl-based/__GUI/Obx/Mod/TabViews.odc new file mode 100644 index 0000000..bcc7973 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/TabViews.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Tabs.odc b/Trurl-based/__GUI/Obx/Mod/Tabs.odc new file mode 100644 index 0000000..6d7d05f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Tabs.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Tickers.odc b/Trurl-based/__GUI/Obx/Mod/Tickers.odc new file mode 100644 index 0000000..668c91d Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Tickers.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Twins.odc b/Trurl-based/__GUI/Obx/Mod/Twins.odc new file mode 100644 index 0000000..5fba6a8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Twins.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/UnitConv.odc b/Trurl-based/__GUI/Obx/Mod/UnitConv.odc new file mode 100644 index 0000000..0285d57 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/UnitConv.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views0.odc b/Trurl-based/__GUI/Obx/Mod/Views0.odc new file mode 100644 index 0000000..b5f1e0b Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views0.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views1.odc b/Trurl-based/__GUI/Obx/Mod/Views1.odc new file mode 100644 index 0000000..f8256f8 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views1.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views10.odc b/Trurl-based/__GUI/Obx/Mod/Views10.odc new file mode 100644 index 0000000..ab6eb6d Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views10.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views11.odc b/Trurl-based/__GUI/Obx/Mod/Views11.odc new file mode 100644 index 0000000..7f83d93 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views11.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views12.odc b/Trurl-based/__GUI/Obx/Mod/Views12.odc new file mode 100644 index 0000000..adefd7c Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views12.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views13.odc b/Trurl-based/__GUI/Obx/Mod/Views13.odc new file mode 100644 index 0000000..268463d Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views13.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views14.odc b/Trurl-based/__GUI/Obx/Mod/Views14.odc new file mode 100644 index 0000000..f470339 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views14.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views2.odc b/Trurl-based/__GUI/Obx/Mod/Views2.odc new file mode 100644 index 0000000..96676f1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views2.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views3.odc b/Trurl-based/__GUI/Obx/Mod/Views3.odc new file mode 100644 index 0000000..56f0aae Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views3.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views4.odc b/Trurl-based/__GUI/Obx/Mod/Views4.odc new file mode 100644 index 0000000..d29fb44 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views4.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views5.odc b/Trurl-based/__GUI/Obx/Mod/Views5.odc new file mode 100644 index 0000000..7a5f191 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views5.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Views6.odc b/Trurl-based/__GUI/Obx/Mod/Views6.odc new file mode 100644 index 0000000..b62ad75 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Views6.odc differ diff --git a/Trurl-based/__GUI/Obx/Mod/Wrappers.odc b/Trurl-based/__GUI/Obx/Mod/Wrappers.odc new file mode 100644 index 0000000..b3544ad Binary files /dev/null and b/Trurl-based/__GUI/Obx/Mod/Wrappers.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Actions.odc b/Trurl-based/__GUI/Obx/Rsrc/Actions.odc new file mode 100644 index 0000000..b9edb6f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Actions.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/BlackBox.odc b/Trurl-based/__GUI/Obx/Rsrc/BlackBox.odc new file mode 100644 index 0000000..6a20616 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/BlackBox.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Controls.odc b/Trurl-based/__GUI/Obx/Rsrc/Controls.odc new file mode 100644 index 0000000..4fe8ba3 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Controls.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Cubes.odc b/Trurl-based/__GUI/Obx/Rsrc/Cubes.odc new file mode 100644 index 0000000..047cd4f Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Cubes.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Dialog.odc b/Trurl-based/__GUI/Obx/Rsrc/Dialog.odc new file mode 100644 index 0000000..b7e4f83 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Dialog.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/FileTree.odc b/Trurl-based/__GUI/Obx/Rsrc/FileTree.odc new file mode 100644 index 0000000..8c8edec Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/FileTree.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Menus.odc b/Trurl-based/__GUI/Obx/Rsrc/Menus.odc new file mode 100644 index 0000000..26474e1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Menus.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Orders.odc b/Trurl-based/__GUI/Obx/Rsrc/Orders.odc new file mode 100644 index 0000000..bba34ec Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Orders.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Orders1.odc b/Trurl-based/__GUI/Obx/Rsrc/Orders1.odc new file mode 100644 index 0000000..277e09a Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Orders1.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/PhoneUI.odc b/Trurl-based/__GUI/Obx/Rsrc/PhoneUI.odc new file mode 100644 index 0000000..ef66314 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/PhoneUI.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/PhoneUI1.odc b/Trurl-based/__GUI/Obx/Rsrc/PhoneUI1.odc new file mode 100644 index 0000000..6744927 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/PhoneUI1.odc differ diff --git a/Trurl-based/__GUI/Obx/Rsrc/Strings.odc b/Trurl-based/__GUI/Obx/Rsrc/Strings.odc new file mode 100644 index 0000000..788d234 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Rsrc/Strings.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/MMData.odc b/Trurl-based/__GUI/Obx/Samples/MMData.odc new file mode 100644 index 0000000..c899eee Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/MMData.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/MMTmpl.odc b/Trurl-based/__GUI/Obx/Samples/MMTmpl.odc new file mode 100644 index 0000000..8375539 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/MMTmpl.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/OData.dat b/Trurl-based/__GUI/Obx/Samples/OData.dat new file mode 100644 index 0000000..65d1469 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/OData.dat differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi1.odc b/Trurl-based/__GUI/Obx/Samples/Omosi1.odc new file mode 100644 index 0000000..88efaad Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi1.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi2.odc b/Trurl-based/__GUI/Obx/Samples/Omosi2.odc new file mode 100644 index 0000000..efb84d1 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi2.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi3.odc b/Trurl-based/__GUI/Obx/Samples/Omosi3.odc new file mode 100644 index 0000000..63d1106 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi3.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi4.odc b/Trurl-based/__GUI/Obx/Samples/Omosi4.odc new file mode 100644 index 0000000..48d1e96 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi4.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi5.odc b/Trurl-based/__GUI/Obx/Samples/Omosi5.odc new file mode 100644 index 0000000..0346a77 Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi5.odc differ diff --git a/Trurl-based/__GUI/Obx/Samples/Omosi6.odc b/Trurl-based/__GUI/Obx/Samples/Omosi6.odc new file mode 100644 index 0000000..61f136c Binary files /dev/null and b/Trurl-based/__GUI/Obx/Samples/Omosi6.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Api.odc b/Trurl-based/__GUI/Std/Docu/Api.odc new file mode 100644 index 0000000..0c623b9 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Api.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/CFrames.odc b/Trurl-based/__GUI/Std/Docu/CFrames.odc new file mode 100644 index 0000000..a1faa1a Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/CFrames.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Clocks.odc b/Trurl-based/__GUI/Std/Docu/Clocks.odc new file mode 100644 index 0000000..17ec7ac Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Clocks.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Cmds.odc b/Trurl-based/__GUI/Std/Docu/Cmds.odc new file mode 100644 index 0000000..fe343c8 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Cmds.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Coder.odc b/Trurl-based/__GUI/Std/Docu/Coder.odc new file mode 100644 index 0000000..4e2d10d Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Coder.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Debug.odc b/Trurl-based/__GUI/Std/Docu/Debug.odc new file mode 100644 index 0000000..7060657 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Debug.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Dialog.odc b/Trurl-based/__GUI/Std/Docu/Dialog.odc new file mode 100644 index 0000000..8998b41 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Dialog.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/ETHConv.odc b/Trurl-based/__GUI/Std/Docu/ETHConv.odc new file mode 100644 index 0000000..0fed5b1 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/ETHConv.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Folds.odc b/Trurl-based/__GUI/Std/Docu/Folds.odc new file mode 100644 index 0000000..38cf3b4 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Folds.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Headers.odc b/Trurl-based/__GUI/Std/Docu/Headers.odc new file mode 100644 index 0000000..2ebde29 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Headers.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Interpreter.odc b/Trurl-based/__GUI/Std/Docu/Interpreter.odc new file mode 100644 index 0000000..c569965 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Interpreter.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Links.odc b/Trurl-based/__GUI/Std/Docu/Links.odc new file mode 100644 index 0000000..f40b3bc Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Links.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Loader.odc b/Trurl-based/__GUI/Std/Docu/Loader.odc new file mode 100644 index 0000000..2e119d7 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Loader.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Log.odc b/Trurl-based/__GUI/Std/Docu/Log.odc new file mode 100644 index 0000000..22bba0a Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Log.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Logos.odc b/Trurl-based/__GUI/Std/Docu/Logos.odc new file mode 100644 index 0000000..b70b091 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Logos.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/MenuTool.odc b/Trurl-based/__GUI/Std/Docu/MenuTool.odc new file mode 100644 index 0000000..5f1d8cf Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/MenuTool.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Scrollers.odc b/Trurl-based/__GUI/Std/Docu/Scrollers.odc new file mode 100644 index 0000000..d053926 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Scrollers.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Stamps.odc b/Trurl-based/__GUI/Std/Docu/Stamps.odc new file mode 100644 index 0000000..0b22200 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Stamps.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Sys-Map.odc b/Trurl-based/__GUI/Std/Docu/Sys-Map.odc new file mode 100644 index 0000000..64efc2b Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Sys-Map.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/TabViews.odc b/Trurl-based/__GUI/Std/Docu/TabViews.odc new file mode 100644 index 0000000..4a42fa3 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/TabViews.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/Tables.odc b/Trurl-based/__GUI/Std/Docu/Tables.odc new file mode 100644 index 0000000..a8e6f14 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/Tables.odc differ diff --git a/Trurl-based/__GUI/Std/Docu/ViewSizer.odc b/Trurl-based/__GUI/Std/Docu/ViewSizer.odc new file mode 100644 index 0000000..1714d51 Binary files /dev/null and b/Trurl-based/__GUI/Std/Docu/ViewSizer.odc differ diff --git a/Trurl-based/__GUI/Std/Mod/MenuTool.odc b/Trurl-based/__GUI/Std/Mod/MenuTool.odc new file mode 100644 index 0000000..c45c2de Binary files /dev/null and b/Trurl-based/__GUI/Std/Mod/MenuTool.odc differ diff --git a/Trurl-based/__GUI/Std/Mod/TabViews.odc b/Trurl-based/__GUI/Std/Mod/TabViews.odc new file mode 100644 index 0000000..7b80a58 Binary files /dev/null and b/Trurl-based/__GUI/Std/Mod/TabViews.odc differ diff --git a/Trurl-based/__GUI/Std/Mod/Tables.odc b/Trurl-based/__GUI/Std/Mod/Tables.odc new file mode 100644 index 0000000..33a098d Binary files /dev/null and b/Trurl-based/__GUI/Std/Mod/Tables.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Cmds.odc b/Trurl-based/__GUI/Std/Rsrc/Cmds.odc new file mode 100644 index 0000000..6472267 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Cmds.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Cmds1.odc b/Trurl-based/__GUI/Std/Rsrc/Cmds1.odc new file mode 100644 index 0000000..18c0108 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Cmds1.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Coder.odc b/Trurl-based/__GUI/Std/Rsrc/Coder.odc new file mode 100644 index 0000000..2b82453 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Coder.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Folds.odc b/Trurl-based/__GUI/Std/Rsrc/Folds.odc new file mode 100644 index 0000000..05e12ce Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Folds.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Headers.odc b/Trurl-based/__GUI/Std/Rsrc/Headers.odc new file mode 100644 index 0000000..3dd2e85 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Headers.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Links.odc b/Trurl-based/__GUI/Std/Rsrc/Links.odc new file mode 100644 index 0000000..1159f32 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Links.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Scroller.odc b/Trurl-based/__GUI/Std/Rsrc/Scroller.odc new file mode 100644 index 0000000..f517c40 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Scroller.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Stamps.odc b/Trurl-based/__GUI/Std/Rsrc/Stamps.odc new file mode 100644 index 0000000..f6523d8 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Stamps.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/TabViews.odc b/Trurl-based/__GUI/Std/Rsrc/TabViews.odc new file mode 100644 index 0000000..19a2569 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/TabViews.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/Tables.odc b/Trurl-based/__GUI/Std/Rsrc/Tables.odc new file mode 100644 index 0000000..9e3f965 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/Tables.odc differ diff --git a/Trurl-based/__GUI/Std/Rsrc/ViewSizer.odc b/Trurl-based/__GUI/Std/Rsrc/ViewSizer.odc new file mode 100644 index 0000000..eaff455 Binary files /dev/null and b/Trurl-based/__GUI/Std/Rsrc/ViewSizer.odc differ diff --git a/Trurl-based/__GUI/System/Docu/In.odc b/Trurl-based/__GUI/System/Docu/In.odc new file mode 100644 index 0000000..9bd14c3 Binary files /dev/null and b/Trurl-based/__GUI/System/Docu/In.odc differ diff --git a/Trurl-based/__GUI/System/Docu/Out.odc b/Trurl-based/__GUI/System/Docu/Out.odc new file mode 100644 index 0000000..10dcce4 Binary files /dev/null and b/Trurl-based/__GUI/System/Docu/Out.odc differ diff --git a/Trurl-based/__GUI/System/Mod/In.odc b/Trurl-based/__GUI/System/Mod/In.odc new file mode 100644 index 0000000..6f00fcf Binary files /dev/null and b/Trurl-based/__GUI/System/Mod/In.odc differ diff --git a/Trurl-based/__GUI/System/Mod/Init.odc b/Trurl-based/__GUI/System/Mod/Init.odc new file mode 100644 index 0000000..ae8571b Binary files /dev/null and b/Trurl-based/__GUI/System/Mod/Init.odc differ diff --git a/Trurl-based/__GUI/System/Mod/Out.odc b/Trurl-based/__GUI/System/Mod/Out.odc new file mode 100644 index 0000000..fd0d449 Binary files /dev/null and b/Trurl-based/__GUI/System/Mod/Out.odc differ diff --git a/Trurl-based/__GUI/System/Rsrc/About.odc b/Trurl-based/__GUI/System/Rsrc/About.odc new file mode 100644 index 0000000..5d0e982 Binary files /dev/null and b/Trurl-based/__GUI/System/Rsrc/About.odc differ diff --git a/Trurl-based/__GUI/System/Rsrc/Menus.odc b/Trurl-based/__GUI/System/Rsrc/Menus.odc new file mode 100644 index 0000000..2b03faa Binary files /dev/null and b/Trurl-based/__GUI/System/Rsrc/Menus.odc differ diff --git a/Trurl-based/__GUI/Tour.odc b/Trurl-based/__GUI/Tour.odc new file mode 100644 index 0000000..f6c907c Binary files /dev/null and b/Trurl-based/__GUI/Tour.odc differ diff --git a/Trurl-based/__Interp/Host/Mod/Dialog.txt b/Trurl-based/__Interp/Host/Mod/Dialog.txt new file mode 100644 index 0000000..6dc303e --- /dev/null +++ b/Trurl-based/__Interp/Host/Mod/Dialog.txt @@ -0,0 +1,52 @@ +MODULE HostDialog; + + (* for StdLog and Dialog.SetShowHook *) + + IMPORT Dialog, Console; + + TYPE + ShowHook = POINTER TO RECORD (Dialog.ShowHook) END; + + PROCEDURE ShowParamMsg* (IN str, p0, p1, p2: ARRAY OF CHAR); + VAR st: ARRAY 512 OF CHAR; + BEGIN + ASSERT(str # "", 20); +(* + IF Dialog.showsStatus THEN + ShowParamStatus(str, p0, p1, p2) + ELSE +*) + Dialog.MapParamString(str, p0, p1, p2, st); + Console.WriteStr(st); Console.WriteLn +(* + END +*) + END ShowParamMsg; + + PROCEDURE ShowParamStatus* (IN str, p0, p1, p2: ARRAY OF CHAR); + VAR st: ARRAY 513 OF CHAR; + BEGIN + Dialog.MapParamString(str, p0, p1, p2, st); + Console.WriteStr(st); Console.WriteLn + END ShowParamStatus; + + PROCEDURE (h: ShowHook) ShowParamMsg (IN str, p0, p1, p2: ARRAY OF CHAR); + BEGIN + ShowParamMsg(str, p0, p1, p2) + END ShowParamMsg; + + PROCEDURE (h: ShowHook) ShowParamStatus (IN str, p0, p1, p2: ARRAY OF CHAR); + BEGIN + ShowParamStatus(str, p0, p1, p2) + END ShowParamStatus; + + PROCEDURE Init; + VAR + showHook: ShowHook; + BEGIN + NEW(showHook); Dialog.SetShowHook(showHook) + END Init; + +BEGIN + Init +END HostDialog. diff --git a/Trurl-based/__Interp/Host/Mod/Fonts.txt b/Trurl-based/__Interp/Host/Mod/Fonts.txt new file mode 100644 index 0000000..28d3f96 --- /dev/null +++ b/Trurl-based/__Interp/Host/Mod/Fonts.txt @@ -0,0 +1,75 @@ +MODULE HostFonts; + + (* for Texts, HostTextConv *) + + IMPORT Fonts; + + CONST + defTypeface = "*"; + defSize = 12 * Fonts.point; + defW = 161925; + defAsc = 142875; + defDsc = 28575; + + TYPE + Font = POINTER TO RECORD (Fonts.Font) + alias-: Fonts.Typeface; (* alias # typeface & typeface # "*" == alien font *) + END; + + Directory = POINTER TO RECORD (Fonts.Directory) END; + + VAR + defFont-: Font; (* for HostTextConv *) + ti: Fonts.TypefaceInfo; + dir: Directory; + + PROCEDURE (f: Font) GetBounds (OUT asc, dsc, w: INTEGER); + BEGIN + asc := defAsc; + dsc := defDsc; + w := defW + END GetBounds; + + PROCEDURE (f: Font) StringWidth (IN s: ARRAY OF CHAR): INTEGER; + BEGIN + RETURN LEN(s$) * defW + END StringWidth; + + PROCEDURE (f: Font) SStringWidth (IN s: ARRAY OF SHORTCHAR): INTEGER; + BEGIN + RETURN LEN(s$) * defW + END SStringWidth; + + PROCEDURE (f: Font) IsAlien (): BOOLEAN; + BEGIN + RETURN TRUE + END IsAlien; + + PROCEDURE (d: Directory) This (typeface: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER): Font; + BEGIN + RETURN defFont + END This; + + PROCEDURE (d: Directory) Default (): Font; + BEGIN + RETURN defFont + END Default; + + PROCEDURE (d: Directory) TypefaceList (): Fonts.TypefaceInfo; + BEGIN + RETURN ti + END TypefaceList; + + PROCEDURE Init; + BEGIN + NEW(defFont); + defFont.Init(defTypeface, defSize, {}, Fonts.normal); + defFont.alias := "Arial"; + NEW(ti); + ti.typeface := defTypeface; + NEW(dir); Fonts.SetDir(dir) + END Init; + +BEGIN + Init +END HostFonts. diff --git a/Trurl-based/__Interp/Host/Mod/Windows.txt b/Trurl-based/__Interp/Host/Mod/Windows.txt new file mode 100644 index 0000000..4200630 --- /dev/null +++ b/Trurl-based/__Interp/Host/Mod/Windows.txt @@ -0,0 +1,143 @@ +MODULE HostWindows; + + (* for Views *) + + IMPORT Windows, Controllers, Views, Files, Converters, Documents, Ports; + + TYPE + Window = POINTER TO EXTENSIBLE RECORD (Windows.Window) + next: Window; (* window ring, to prevent garbage collection of windows *) + END; + + Directory = POINTER TO EXTENSIBLE RECORD (Windows.Directory) + END; + + VAR + dir: Directory; + winAnchor: Window; (* list of all windows, from top to bottom, first is dumy header *) + + (** Window **) + + PROCEDURE (w: Window) ForwardCtrlMsg (VAR msg: Controllers.Message), EXTENSIBLE; + BEGIN + HALT(126) + END ForwardCtrlMsg; + + PROCEDURE (w: Window) SetSize (width, height: INTEGER); + BEGIN + HALT(126) + END SetSize; + + PROCEDURE (w: Window) SetTitle (title: Views.Title); + BEGIN + HALT(126) + END SetTitle; + + PROCEDURE (w: Window) RefreshTitle; + BEGIN + HALT(126) + END RefreshTitle; + + PROCEDURE (w: Window) GetTitle (OUT title: Views.Title); + BEGIN + HALT(126) + END GetTitle; + + PROCEDURE (w: Window) SetSpec (loc: Files.Locator; name: Files.Name; conv: Converters.Converter); + BEGIN + HALT(126) + END SetSpec; + + PROCEDURE (w: Window) MouseDown (x, y, time: INTEGER; modifiers: SET); + BEGIN + HALT(126) + END MouseDown; + + PROCEDURE (w: Window) KeyDown (ch: CHAR; buttons: SET); + BEGIN + HALT(126) + END KeyDown; + + PROCEDURE (w: Window) Close; + BEGIN + ASSERT(w.frame # NIL, 20); + HALT(126); + w.Close^; + ASSERT(w.frame = NIL, 60) + END Close; + + (* Directory *) + + PROCEDURE (d: Directory) Open ( + w: Windows.Window; doc: Documents.Document; flags: SET; name: Views.Title; + loc: Files.Locator; fname: Files.Name; conv: Converters.Converter + ); + VAR p: Ports.Port; + BEGIN + WITH w: Window DO + END + END Open; + + PROCEDURE (d: Directory) First (): Window; + BEGIN + RETURN winAnchor.next + END First; + + PROCEDURE (d: Directory) Next (w: Windows.Window): Window; + BEGIN + IF w # NIL THEN RETURN w(Window).next ELSE RETURN NIL END + END Next; + + PROCEDURE (d: Directory) New (): Window, EXTENSIBLE; + VAR w: Window; + BEGIN + NEW(w); RETURN w + END New; + + PROCEDURE (d: Directory) Focus (target: BOOLEAN): Window; + BEGIN + HALT(126); + RETURN NIL + END Focus; + + PROCEDURE (d: Directory) Select (w: Windows.Window; lazy: BOOLEAN); + BEGIN + WITH w: Window DO + HALT(126) + END + END Select; + + PROCEDURE (d: Directory) GetThisWindow (p: Ports.Port; px, py: INTEGER; + OUT x, y: INTEGER; OUT w: Windows.Window); + BEGIN + w := NIL + END GetThisWindow; + + PROCEDURE (d: Directory) Close (w: Windows.Window); + VAR v, u: Windows.Window; h: Window; + BEGIN + h := winAnchor; WHILE (h.next # NIL) & (h.next # w) DO h := h.next END; + IF h.next = w THEN + IF ~w.sub THEN + v := w.link; + WHILE v # w DO u := v.link; v.Close; v := u END + END; + w.Close + END + END Close; + + PROCEDURE (d: Directory) GetBounds (OUT w, h: INTEGER); + BEGIN + HALT(126) + END GetBounds; + + PROCEDURE Init; + VAR d: Directory; + BEGIN + NEW(d); d.l := -1; d.t := -1; d.r := -1; d.b := -1; dir := d; Windows.SetDir(d); + NEW(winAnchor); winAnchor.next := NIL; (* dummy header *) + END Init; + +BEGIN + Init +END HostWindows. diff --git a/Trurl-based/__Interp/System/Mod/Init.txt b/Trurl-based/__Interp/System/Mod/Init.txt new file mode 100644 index 0000000..0d56a57 --- /dev/null +++ b/Trurl-based/__Interp/System/Mod/Init.txt @@ -0,0 +1,28 @@ +MODULE Init; + + IMPORT + HostConsole, (* Console.SetHook *) + + HostFonts (* Fonts.SetHook; required for Texts *), + HostWindows (* Windows.SetHook *), + HostDates (* Dates.SetHook *), + HostDialog (* Dialog.SetShowHook *), + StdInterpreter, (* Dialog.SetCallHook *) + StdDialog (* Views.SetViewHook *), + + StdLog, ConsLog, (* Log.Hook *) + + Converters (* .odc *), + Dialog; + + PROCEDURE Init; + VAR res: INTEGER; + BEGIN + Converters.Register("Documents.ImportDocument", "Documents.ExportDocument", "", "odc", {}); + Dialog.Call("Config.Setup", " ", res); + Dialog.Call("ConsInterp.Run", " ", res) + END Init; + +BEGIN + Init +END Init. diff --git a/Trurl-based/build b/Trurl-based/build new file mode 100755 index 0000000..14a5504 --- /dev/null +++ b/Trurl-based/build @@ -0,0 +1,131 @@ +#!/bin/sh + +./run-dev0 <