From: Alexander Shiryaev Date: Fri, 16 Nov 2012 19:47:16 +0000 (+0400) Subject: Dev0 removed X-Git-Url: https://deadsoftware.ru/gitweb?a=commitdiff_plain;h=7c7fa4aee82b89fc5e889e23ebb90f449ac71837;hp=4d118bc168ef105230b75f358c6917ed7ee5cbd3;p=bbcp.git Dev0 removed --- diff --git a/new/Cons/Mod/Interp.odc b/new/Cons/Mod/Interp.odc new file mode 100644 index 0000000..0b5e294 Binary files /dev/null and b/new/Cons/Mod/Interp.odc differ diff --git a/new/Cons/Mod/Interp.txt b/new/Cons/Mod/Interp.txt deleted file mode 100644 index 9dac7e9..0000000 --- a/new/Cons/Mod/Interp.txt +++ /dev/null @@ -1,128 +0,0 @@ -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/new/Cons/Mod/Log.odc b/new/Cons/Mod/Log.odc new file mode 100644 index 0000000..722604d Binary files /dev/null and b/new/Cons/Mod/Log.odc differ diff --git a/new/Cons/Mod/Log.txt b/new/Cons/Mod/Log.txt deleted file mode 100644 index 87f4fd6..0000000 --- a/new/Cons/Mod/Log.txt +++ /dev/null @@ -1,193 +0,0 @@ -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/new/Dev/Mod/CPB.odc b/new/Dev/Mod/CPB.odc new file mode 100644 index 0000000..9b48385 Binary files /dev/null and b/new/Dev/Mod/CPB.odc differ diff --git a/new/Dev/Mod/CPB.txt b/new/Dev/Mod/CPB.txt deleted file mode 100644 index 56a840a..0000000 --- a/new/Dev/Mod/CPB.txt +++ /dev/null @@ -1,2238 +0,0 @@ -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/new/Dev/Mod/CPC486.odc b/new/Dev/Mod/CPC486.odc new file mode 100644 index 0000000..39ba9a5 Binary files /dev/null and b/new/Dev/Mod/CPC486.odc differ diff --git a/new/Dev/Mod/CPC486.txt b/new/Dev/Mod/CPC486.txt deleted file mode 100644 index 1a952d9..0000000 --- a/new/Dev/Mod/CPC486.txt +++ /dev/null @@ -1,2333 +0,0 @@ -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/new/Dev/Mod/CPE.odc b/new/Dev/Mod/CPE.odc new file mode 100644 index 0000000..f5992b5 Binary files /dev/null and b/new/Dev/Mod/CPE.odc differ diff --git a/new/Dev/Mod/CPE.txt b/new/Dev/Mod/CPE.txt deleted file mode 100644 index f864ca7..0000000 --- a/new/Dev/Mod/CPE.txt +++ /dev/null @@ -1,1105 +0,0 @@ -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/new/Dev/Mod/CPH.odc b/new/Dev/Mod/CPH.odc new file mode 100644 index 0000000..70c43c0 Binary files /dev/null and b/new/Dev/Mod/CPH.odc differ diff --git a/new/Dev/Mod/CPH.txt b/new/Dev/Mod/CPH.txt deleted file mode 100644 index c55a9e6..0000000 --- a/new/Dev/Mod/CPH.txt +++ /dev/null @@ -1,291 +0,0 @@ -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/new/Dev/Mod/CPL486.odc b/new/Dev/Mod/CPL486.odc new file mode 100644 index 0000000..7300aa8 Binary files /dev/null and b/new/Dev/Mod/CPL486.odc differ diff --git a/new/Dev/Mod/CPL486.txt b/new/Dev/Mod/CPL486.txt deleted file mode 100644 index a0ae315..0000000 --- a/new/Dev/Mod/CPL486.txt +++ /dev/null @@ -1,1057 +0,0 @@ -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/new/Dev/Mod/CPM.odc b/new/Dev/Mod/CPM.odc new file mode 100644 index 0000000..5473454 Binary files /dev/null and b/new/Dev/Mod/CPM.odc differ diff --git a/new/Dev/Mod/CPM.txt b/new/Dev/Mod/CPM.txt deleted file mode 100644 index 71c432b..0000000 --- a/new/Dev/Mod/CPM.txt +++ /dev/null @@ -1,853 +0,0 @@ -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/new/Dev/Mod/CPP.odc b/new/Dev/Mod/CPP.odc new file mode 100644 index 0000000..640c207 Binary files /dev/null and b/new/Dev/Mod/CPP.odc differ diff --git a/new/Dev/Mod/CPP.txt b/new/Dev/Mod/CPP.txt deleted file mode 100644 index b2fa032..0000000 --- a/new/Dev/Mod/CPP.txt +++ /dev/null @@ -1,1650 +0,0 @@ -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/new/Dev/Mod/CPS.odc b/new/Dev/Mod/CPS.odc new file mode 100644 index 0000000..83b38d9 Binary files /dev/null and b/new/Dev/Mod/CPS.odc differ diff --git a/new/Dev/Mod/CPS.txt b/new/Dev/Mod/CPS.txt deleted file mode 100644 index ea2d746..0000000 --- a/new/Dev/Mod/CPS.txt +++ /dev/null @@ -1,367 +0,0 @@ -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/new/Dev/Mod/CPT.odc b/new/Dev/Mod/CPT.odc new file mode 100644 index 0000000..af6dab3 Binary files /dev/null and b/new/Dev/Mod/CPT.odc differ diff --git a/new/Dev/Mod/CPT.txt b/new/Dev/Mod/CPT.txt deleted file mode 100644 index 2fdbc03..0000000 --- a/new/Dev/Mod/CPT.txt +++ /dev/null @@ -1,1890 +0,0 @@ -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/new/Dev/Mod/CPV486.odc b/new/Dev/Mod/CPV486.odc new file mode 100644 index 0000000..d90a3a8 Binary files /dev/null and b/new/Dev/Mod/CPV486.odc differ diff --git a/new/Dev/Mod/CPV486.txt b/new/Dev/Mod/CPV486.txt deleted file mode 100644 index 96851ea..0000000 --- a/new/Dev/Mod/CPV486.txt +++ /dev/null @@ -1,1774 +0,0 @@ -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/new/Dev/Mod/Commanders.odc b/new/Dev/Mod/Commanders.odc new file mode 100644 index 0000000..59aaf0a Binary files /dev/null and b/new/Dev/Mod/Commanders.odc differ diff --git a/new/Dev/Mod/Commanders.txt b/new/Dev/Mod/Commanders.txt deleted file mode 100644 index 4d102e7..0000000 --- a/new/Dev/Mod/Commanders.txt +++ /dev/null @@ -1,361 +0,0 @@ -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/new/Dev/Mod/Compiler.odc b/new/Dev/Mod/Compiler.odc new file mode 100644 index 0000000..1e1bb53 Binary files /dev/null and b/new/Dev/Mod/Compiler.odc differ diff --git a/new/Dev/Mod/Compiler.txt b/new/Dev/Mod/Compiler.txt deleted file mode 100644 index 6aa0761..0000000 --- a/new/Dev/Mod/Compiler.txt +++ /dev/null @@ -1,348 +0,0 @@ -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/new/Dev/Mod/Markers.odc b/new/Dev/Mod/Markers.odc new file mode 100644 index 0000000..f3efde2 Binary files /dev/null and b/new/Dev/Mod/Markers.odc differ diff --git a/new/Dev/Mod/Markers.txt b/new/Dev/Mod/Markers.txt deleted file mode 100644 index b402b5b..0000000 --- a/new/Dev/Mod/Markers.txt +++ /dev/null @@ -1,442 +0,0 @@ -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/new/Dev/Mod/Selectors.odc b/new/Dev/Mod/Selectors.odc new file mode 100644 index 0000000..93231d7 Binary files /dev/null and b/new/Dev/Mod/Selectors.odc differ diff --git a/new/Dev/Mod/Selectors.txt b/new/Dev/Mod/Selectors.txt deleted file mode 100644 index 81d265f..0000000 --- a/new/Dev/Mod/Selectors.txt +++ /dev/null @@ -1,411 +0,0 @@ -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/new/Dev0/Mod/CPB.odc b/new/Dev0/Mod/CPB.odc deleted file mode 100644 index 6446649..0000000 Binary files a/new/Dev0/Mod/CPB.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPB.txt b/new/Dev0/Mod/CPB.txt deleted file mode 100644 index 33cf1d1..0000000 --- a/new/Dev0/Mod/CPB.txt +++ /dev/null @@ -1,2251 +0,0 @@ -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/new/Dev0/Mod/CPC486.odc b/new/Dev0/Mod/CPC486.odc deleted file mode 100644 index 4c05887..0000000 Binary files a/new/Dev0/Mod/CPC486.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPC486.txt b/new/Dev0/Mod/CPC486.txt deleted file mode 100644 index 5200c4b..0000000 --- a/new/Dev0/Mod/CPC486.txt +++ /dev/null @@ -1,2347 +0,0 @@ -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/new/Dev0/Mod/CPE.odc b/new/Dev0/Mod/CPE.odc deleted file mode 100644 index 3d1952b..0000000 Binary files a/new/Dev0/Mod/CPE.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPE.txt b/new/Dev0/Mod/CPE.txt deleted file mode 100644 index 798b19e..0000000 --- a/new/Dev0/Mod/CPE.txt +++ /dev/null @@ -1,1120 +0,0 @@ -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/new/Dev0/Mod/CPH.odc b/new/Dev0/Mod/CPH.odc deleted file mode 100644 index 4dcb383..0000000 Binary files a/new/Dev0/Mod/CPH.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPH.txt b/new/Dev0/Mod/CPH.txt deleted file mode 100644 index 3d57237..0000000 --- a/new/Dev0/Mod/CPH.txt +++ /dev/null @@ -1,304 +0,0 @@ -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/new/Dev0/Mod/CPL486.odc b/new/Dev0/Mod/CPL486.odc deleted file mode 100644 index b96a99c..0000000 Binary files a/new/Dev0/Mod/CPL486.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPL486.txt b/new/Dev0/Mod/CPL486.txt deleted file mode 100644 index 0c2987a..0000000 --- a/new/Dev0/Mod/CPL486.txt +++ /dev/null @@ -1,1070 +0,0 @@ -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/new/Dev0/Mod/CPM.odc b/new/Dev0/Mod/CPM.odc deleted file mode 100644 index 0049d01..0000000 Binary files a/new/Dev0/Mod/CPM.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPM.txt b/new/Dev0/Mod/CPM.txt deleted file mode 100644 index 583483c..0000000 --- a/new/Dev0/Mod/CPM.txt +++ /dev/null @@ -1,809 +0,0 @@ -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/new/Dev0/Mod/CPP.odc b/new/Dev0/Mod/CPP.odc deleted file mode 100644 index 0cd6ae1..0000000 Binary files a/new/Dev0/Mod/CPP.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPP.txt b/new/Dev0/Mod/CPP.txt deleted file mode 100644 index bd729fb..0000000 --- a/new/Dev0/Mod/CPP.txt +++ /dev/null @@ -1,1662 +0,0 @@ -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/new/Dev0/Mod/CPS.odc b/new/Dev0/Mod/CPS.odc deleted file mode 100644 index 8548317..0000000 Binary files a/new/Dev0/Mod/CPS.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPS.txt b/new/Dev0/Mod/CPS.txt deleted file mode 100644 index e989a83..0000000 --- a/new/Dev0/Mod/CPS.txt +++ /dev/null @@ -1,379 +0,0 @@ -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/new/Dev0/Mod/CPT.odc b/new/Dev0/Mod/CPT.odc deleted file mode 100644 index a858cbb..0000000 Binary files a/new/Dev0/Mod/CPT.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPT.txt b/new/Dev0/Mod/CPT.txt deleted file mode 100644 index c8253ee..0000000 --- a/new/Dev0/Mod/CPT.txt +++ /dev/null @@ -1,1904 +0,0 @@ -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/new/Dev0/Mod/CPV486.odc b/new/Dev0/Mod/CPV486.odc deleted file mode 100644 index 3e32c73..0000000 Binary files a/new/Dev0/Mod/CPV486.odc and /dev/null differ diff --git a/new/Dev0/Mod/CPV486.txt b/new/Dev0/Mod/CPV486.txt deleted file mode 100644 index c45e892..0000000 --- a/new/Dev0/Mod/CPV486.txt +++ /dev/null @@ -1,1788 +0,0 @@ -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/new/Dev0/Mod/Compiler.odc b/new/Dev0/Mod/Compiler.odc deleted file mode 100644 index 8449f33..0000000 Binary files a/new/Dev0/Mod/Compiler.odc and /dev/null differ diff --git a/new/Dev0/Mod/Compiler.txt b/new/Dev0/Mod/Compiler.txt deleted file mode 100644 index 26b638f..0000000 --- a/new/Dev0/Mod/Compiler.txt +++ /dev/null @@ -1,140 +0,0 @@ -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/new/Dev0/Mod/ElfLinker16.odc b/new/Dev0/Mod/ElfLinker16.odc deleted file mode 100644 index 0b74d87..0000000 Binary files a/new/Dev0/Mod/ElfLinker16.odc and /dev/null differ diff --git a/new/Dev0/Mod/ElfLinker16.txt b/new/Dev0/Mod/ElfLinker16.txt deleted file mode 100644 index 808804a..0000000 --- a/new/Dev0/Mod/ElfLinker16.txt +++ /dev/null @@ -1,1892 +0,0 @@ -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/new/Dev0/Mod/Interp.txt b/new/Dev0/Mod/Interp.txt deleted file mode 100644 index f4ab977..0000000 --- a/new/Dev0/Mod/Interp.txt +++ /dev/null @@ -1,56 +0,0 @@ -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/new/Dev0/Mod/Linker.odc b/new/Dev0/Mod/Linker.odc deleted file mode 100644 index d07ac20..0000000 Binary files a/new/Dev0/Mod/Linker.odc and /dev/null differ diff --git a/new/Dev0/Mod/Linker.txt b/new/Dev0/Mod/Linker.txt deleted file mode 100644 index 874bf1a..0000000 --- a/new/Dev0/Mod/Linker.txt +++ /dev/null @@ -1,1779 +0,0 @@ -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/new/Dev0/Views.txt b/new/Dev0/Views.txt deleted file mode 100644 index 9f4e270..0000000 --- a/new/Dev0/Views.txt +++ /dev/null @@ -1,14 +0,0 @@ -MODULE Views; - - (* TO COMPILE StdInterpreter *) - - PROCEDURE Available* (): INTEGER; - BEGIN - RETURN 0 - END Available; - - PROCEDURE ClearQueue*; - BEGIN - END ClearQueue; - -END Views. diff --git a/new/Std/Mod/Api.odc b/new/Std/Mod/Api.odc new file mode 100644 index 0000000..a4f7a6b Binary files /dev/null and b/new/Std/Mod/Api.odc differ diff --git a/new/Std/Mod/CFrames.odc b/new/Std/Mod/CFrames.odc new file mode 100644 index 0000000..bfb5b5b Binary files /dev/null and b/new/Std/Mod/CFrames.odc differ diff --git a/new/Std/Mod/Clocks.odc b/new/Std/Mod/Clocks.odc new file mode 100644 index 0000000..49e0389 Binary files /dev/null and b/new/Std/Mod/Clocks.odc differ diff --git a/new/Std/Mod/Cmds.odc b/new/Std/Mod/Cmds.odc new file mode 100644 index 0000000..49bee1e Binary files /dev/null and b/new/Std/Mod/Cmds.odc differ diff --git a/new/Std/Mod/Coder.odc b/new/Std/Mod/Coder.odc new file mode 100644 index 0000000..e8cdd96 Binary files /dev/null and b/new/Std/Mod/Coder.odc differ diff --git a/new/Std/Mod/Debug.odc b/new/Std/Mod/Debug.odc new file mode 100644 index 0000000..6be64ec Binary files /dev/null and b/new/Std/Mod/Debug.odc differ diff --git a/new/Std/Mod/Dialog.odc b/new/Std/Mod/Dialog.odc new file mode 100644 index 0000000..799397f Binary files /dev/null and b/new/Std/Mod/Dialog.odc differ diff --git a/new/Std/Mod/ETHConv.odc b/new/Std/Mod/ETHConv.odc new file mode 100644 index 0000000..28d446c Binary files /dev/null and b/new/Std/Mod/ETHConv.odc differ diff --git a/new/Std/Mod/Folds.odc b/new/Std/Mod/Folds.odc new file mode 100644 index 0000000..7e50952 Binary files /dev/null and b/new/Std/Mod/Folds.odc differ diff --git a/new/Std/Mod/Headers.odc b/new/Std/Mod/Headers.odc new file mode 100644 index 0000000..de4be99 Binary files /dev/null and b/new/Std/Mod/Headers.odc differ diff --git a/new/Std/Mod/Interpreter.odc b/new/Std/Mod/Interpreter.odc new file mode 100644 index 0000000..c94801b Binary files /dev/null and b/new/Std/Mod/Interpreter.odc differ diff --git a/new/Std/Mod/Links.odc b/new/Std/Mod/Links.odc new file mode 100644 index 0000000..609a250 Binary files /dev/null and b/new/Std/Mod/Links.odc differ diff --git a/new/Std/Mod/Loader.odc b/new/Std/Mod/Loader.odc new file mode 100644 index 0000000..4dc2274 Binary files /dev/null and b/new/Std/Mod/Loader.odc differ diff --git a/new/Std/Mod/Log.odc b/new/Std/Mod/Log.odc new file mode 100644 index 0000000..c868963 Binary files /dev/null and b/new/Std/Mod/Log.odc differ diff --git a/new/Std/Mod/Logos.odc b/new/Std/Mod/Logos.odc new file mode 100644 index 0000000..f06491f Binary files /dev/null and b/new/Std/Mod/Logos.odc differ diff --git a/new/Std/Mod/Scrollers.odc b/new/Std/Mod/Scrollers.odc new file mode 100644 index 0000000..7791b17 Binary files /dev/null and b/new/Std/Mod/Scrollers.odc differ diff --git a/new/Std/Mod/Stamps.odc b/new/Std/Mod/Stamps.odc new file mode 100644 index 0000000..5c18847 Binary files /dev/null and b/new/Std/Mod/Stamps.odc differ diff --git a/new/Std/Mod/ViewSizer.odc b/new/Std/Mod/ViewSizer.odc new file mode 100644 index 0000000..17dd55c Binary files /dev/null and b/new/Std/Mod/ViewSizer.odc differ diff --git a/new/__GUI/System/Docu/In.odc b/new/System/Docu/In.odc similarity index 100% rename from new/__GUI/System/Docu/In.odc rename to new/System/Docu/In.odc diff --git a/new/__GUI/System/Docu/Out.odc b/new/System/Docu/Out.odc similarity index 100% rename from new/__GUI/System/Docu/Out.odc rename to new/System/Docu/Out.odc diff --git a/new/System/Mod/Console.txt b/new/System/Mod/Console.txt deleted file mode 100644 index 25c983a..0000000 --- a/new/System/Mod/Console.txt +++ /dev/null @@ -1,58 +0,0 @@ -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/new/System/Mod/Containers.odc b/new/System/Mod/Containers.odc new file mode 100644 index 0000000..40fba97 Binary files /dev/null and b/new/System/Mod/Containers.odc differ diff --git a/new/System/Mod/Containers.txt b/new/System/Mod/Containers.txt deleted file mode 100644 index 32270d5..0000000 --- a/new/System/Mod/Containers.txt +++ /dev/null @@ -1,1381 +0,0 @@ -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/new/System/Mod/Controllers.odc b/new/System/Mod/Controllers.odc new file mode 100644 index 0000000..69a7a38 Binary files /dev/null and b/new/System/Mod/Controllers.odc differ diff --git a/new/System/Mod/Controllers.txt b/new/System/Mod/Controllers.txt deleted file mode 100644 index c0eed4e..0000000 --- a/new/System/Mod/Controllers.txt +++ /dev/null @@ -1,426 +0,0 @@ -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/new/System/Mod/Controls.odc b/new/System/Mod/Controls.odc new file mode 100644 index 0000000..0abca3c Binary files /dev/null and b/new/System/Mod/Controls.odc differ diff --git a/new/System/Mod/Controls.txt b/new/System/Mod/Controls.txt deleted file mode 100644 index 6edecba..0000000 --- a/new/System/Mod/Controls.txt +++ /dev/null @@ -1,3163 +0,0 @@ -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/new/System/Mod/Converters.odc b/new/System/Mod/Converters.odc new file mode 100644 index 0000000..753d0fb Binary files /dev/null and b/new/System/Mod/Converters.odc differ diff --git a/new/System/Mod/Converters.txt b/new/System/Mod/Converters.txt deleted file mode 100644 index 1d1c557..0000000 --- a/new/System/Mod/Converters.txt +++ /dev/null @@ -1,105 +0,0 @@ -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/new/System/Mod/Dates.odc b/new/System/Mod/Dates.odc new file mode 100644 index 0000000..e7e5097 Binary files /dev/null and b/new/System/Mod/Dates.odc differ diff --git a/new/System/Mod/Dates.txt b/new/System/Mod/Dates.txt deleted file mode 100644 index 82a5552..0000000 --- a/new/System/Mod/Dates.txt +++ /dev/null @@ -1,191 +0,0 @@ -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/new/System/Mod/Dialog.odc b/new/System/Mod/Dialog.odc new file mode 100644 index 0000000..63378db Binary files /dev/null and b/new/System/Mod/Dialog.odc differ diff --git a/new/System/Mod/Dialog.txt b/new/System/Mod/Dialog.txt deleted file mode 100644 index 7726be1..0000000 --- a/new/System/Mod/Dialog.txt +++ /dev/null @@ -1,1202 +0,0 @@ -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/new/System/Mod/Documents.odc b/new/System/Mod/Documents.odc new file mode 100644 index 0000000..b7c2489 Binary files /dev/null and b/new/System/Mod/Documents.odc differ diff --git a/new/System/Mod/Documents.txt b/new/System/Mod/Documents.txt deleted file mode 100644 index 2450a66..0000000 --- a/new/System/Mod/Documents.txt +++ /dev/null @@ -1,1286 +0,0 @@ -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/new/System/Mod/Files.odc b/new/System/Mod/Files.odc new file mode 100644 index 0000000..fb44f00 Binary files /dev/null and b/new/System/Mod/Files.odc differ diff --git a/new/System/Mod/Files.txt b/new/System/Mod/Files.txt deleted file mode 100644 index 59d373e..0000000 --- a/new/System/Mod/Files.txt +++ /dev/null @@ -1,110 +0,0 @@ -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/new/System/Mod/Fonts.odc b/new/System/Mod/Fonts.odc new file mode 100644 index 0000000..5752b8c Binary files /dev/null and b/new/System/Mod/Fonts.odc differ diff --git a/new/System/Mod/Fonts.txt b/new/System/Mod/Fonts.txt deleted file mode 100644 index e97e6ba..0000000 --- a/new/System/Mod/Fonts.txt +++ /dev/null @@ -1,59 +0,0 @@ -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/new/__GUI/System/Mod/In.odc b/new/System/Mod/In.odc similarity index 100% rename from new/__GUI/System/Mod/In.odc rename to new/System/Mod/In.odc diff --git a/new/System/Mod/In.txt b/new/System/Mod/In.txt deleted file mode 100644 index 2d5f7a0..0000000 --- a/new/System/Mod/In.txt +++ /dev/null @@ -1,87 +0,0 @@ -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/new/System/Mod/Integers.odc b/new/System/Mod/Integers.odc new file mode 100644 index 0000000..bd9d450 Binary files /dev/null and b/new/System/Mod/Integers.odc differ diff --git a/new/System/Mod/Integers.txt b/new/System/Mod/Integers.txt deleted file mode 100644 index 570eb37..0000000 --- a/new/System/Mod/Integers.txt +++ /dev/null @@ -1,848 +0,0 @@ -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/new/System/Mod/Log.odc b/new/System/Mod/Log.odc new file mode 100644 index 0000000..6844660 Binary files /dev/null and b/new/System/Mod/Log.odc differ diff --git a/new/System/Mod/Log.txt b/new/System/Mod/Log.txt deleted file mode 100644 index ea32ffa..0000000 --- a/new/System/Mod/Log.txt +++ /dev/null @@ -1,144 +0,0 @@ -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/new/System/Mod/Math.odc b/new/System/Mod/Math.odc new file mode 100644 index 0000000..e3c48ec Binary files /dev/null and b/new/System/Mod/Math.odc differ diff --git a/new/System/Mod/Math.txt b/new/System/Mod/Math.txt deleted file mode 100644 index 936cf15..0000000 --- a/new/System/Mod/Math.txt +++ /dev/null @@ -1,532 +0,0 @@ -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/new/System/Mod/Mechanisms.odc b/new/System/Mod/Mechanisms.odc new file mode 100644 index 0000000..b4c0d86 Binary files /dev/null and b/new/System/Mod/Mechanisms.odc differ diff --git a/new/System/Mod/Mechanisms.txt b/new/System/Mod/Mechanisms.txt deleted file mode 100644 index 078c8ff..0000000 --- a/new/System/Mod/Mechanisms.txt +++ /dev/null @@ -1,129 +0,0 @@ -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/new/System/Mod/Meta.odc b/new/System/Mod/Meta.odc new file mode 100644 index 0000000..d294ff3 Binary files /dev/null and b/new/System/Mod/Meta.odc differ diff --git a/new/System/Mod/Meta.txt b/new/System/Mod/Meta.txt deleted file mode 100644 index ca36176..0000000 --- a/new/System/Mod/Meta.txt +++ /dev/null @@ -1,1214 +0,0 @@ -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/new/System/Mod/Models.odc b/new/System/Mod/Models.odc new file mode 100644 index 0000000..179464f Binary files /dev/null and b/new/System/Mod/Models.odc differ diff --git a/new/System/Mod/Models.txt b/new/System/Mod/Models.txt deleted file mode 100644 index c3b1ba9..0000000 --- a/new/System/Mod/Models.txt +++ /dev/null @@ -1,258 +0,0 @@ -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/new/__GUI/System/Mod/Out.odc b/new/System/Mod/Out.odc similarity index 100% rename from new/__GUI/System/Mod/Out.odc rename to new/System/Mod/Out.odc diff --git a/new/System/Mod/Ports.odc b/new/System/Mod/Ports.odc new file mode 100644 index 0000000..12814c6 Binary files /dev/null and b/new/System/Mod/Ports.odc differ diff --git a/new/System/Mod/Ports.txt b/new/System/Mod/Ports.txt deleted file mode 100644 index 93731f7..0000000 --- a/new/System/Mod/Ports.txt +++ /dev/null @@ -1,318 +0,0 @@ -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/new/System/Mod/Printers.odc b/new/System/Mod/Printers.odc new file mode 100644 index 0000000..07009f9 Binary files /dev/null and b/new/System/Mod/Printers.odc differ diff --git a/new/System/Mod/Printers.txt b/new/System/Mod/Printers.txt deleted file mode 100644 index e79e4ec..0000000 --- a/new/System/Mod/Printers.txt +++ /dev/null @@ -1,63 +0,0 @@ -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/new/System/Mod/Printing.odc b/new/System/Mod/Printing.odc new file mode 100644 index 0000000..9493e84 Binary files /dev/null and b/new/System/Mod/Printing.odc differ diff --git a/new/System/Mod/Printing.txt b/new/System/Mod/Printing.txt deleted file mode 100644 index 02555ab..0000000 --- a/new/System/Mod/Printing.txt +++ /dev/null @@ -1,226 +0,0 @@ -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/new/System/Mod/Properties.odc b/new/System/Mod/Properties.odc new file mode 100644 index 0000000..031291c Binary files /dev/null and b/new/System/Mod/Properties.odc differ diff --git a/new/System/Mod/Properties.txt b/new/System/Mod/Properties.txt deleted file mode 100644 index d60479f..0000000 --- a/new/System/Mod/Properties.txt +++ /dev/null @@ -1,425 +0,0 @@ -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/new/System/Mod/SMath.odc b/new/System/Mod/SMath.odc new file mode 100644 index 0000000..f5a7706 Binary files /dev/null and b/new/System/Mod/SMath.odc differ diff --git a/new/System/Mod/SMath.txt b/new/System/Mod/SMath.txt deleted file mode 100644 index a512f83..0000000 --- a/new/System/Mod/SMath.txt +++ /dev/null @@ -1,392 +0,0 @@ -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/new/System/Mod/Sequencers.odc b/new/System/Mod/Sequencers.odc new file mode 100644 index 0000000..024593e Binary files /dev/null and b/new/System/Mod/Sequencers.odc differ diff --git a/new/System/Mod/Sequencers.txt b/new/System/Mod/Sequencers.txt deleted file mode 100644 index fe2e1c3..0000000 --- a/new/System/Mod/Sequencers.txt +++ /dev/null @@ -1,86 +0,0 @@ -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/new/System/Mod/Services.odc b/new/System/Mod/Services.odc new file mode 100644 index 0000000..6fb5caf Binary files /dev/null and b/new/System/Mod/Services.odc differ diff --git a/new/System/Mod/Services.txt b/new/System/Mod/Services.txt deleted file mode 100644 index 6ad9cae..0000000 --- a/new/System/Mod/Services.txt +++ /dev/null @@ -1,256 +0,0 @@ -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/new/System/Mod/Stores.odc b/new/System/Mod/Stores.odc new file mode 100644 index 0000000..57627ea Binary files /dev/null and b/new/System/Mod/Stores.odc differ diff --git a/new/System/Mod/Stores.txt b/new/System/Mod/Stores.txt deleted file mode 100644 index e51dc2c..0000000 --- a/new/System/Mod/Stores.txt +++ /dev/null @@ -1,1313 +0,0 @@ -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/new/System/Mod/Strings.odc b/new/System/Mod/Strings.odc new file mode 100644 index 0000000..1c32594 Binary files /dev/null and b/new/System/Mod/Strings.odc differ diff --git a/new/System/Mod/Strings.txt b/new/System/Mod/Strings.txt deleted file mode 100644 index f675044..0000000 --- a/new/System/Mod/Strings.txt +++ /dev/null @@ -1,565 +0,0 @@ -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/new/System/Mod/Views.odc b/new/System/Mod/Views.odc new file mode 100644 index 0000000..f1553bf Binary files /dev/null and b/new/System/Mod/Views.odc differ diff --git a/new/System/Mod/Views.txt b/new/System/Mod/Views.txt deleted file mode 100644 index f3a2294..0000000 --- a/new/System/Mod/Views.txt +++ /dev/null @@ -1,1347 +0,0 @@ -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/new/System/Mod/Windows.odc b/new/System/Mod/Windows.odc new file mode 100644 index 0000000..425806c Binary files /dev/null and b/new/System/Mod/Windows.odc differ diff --git a/new/System/Mod/Windows.txt b/new/System/Mod/Windows.txt deleted file mode 100644 index abe145d..0000000 --- a/new/System/Mod/Windows.txt +++ /dev/null @@ -1,855 +0,0 @@ -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/new/Text/Mod/Cmds.txt b/new/Text/Mod/Cmds.txt deleted file mode 100644 index 1966552..0000000 --- a/new/Text/Mod/Cmds.txt +++ /dev/null @@ -1,860 +0,0 @@ -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/new/Text/Mod/Controllers.txt b/new/Text/Mod/Controllers.txt deleted file mode 100644 index 470727e..0000000 --- a/new/Text/Mod/Controllers.txt +++ /dev/null @@ -1,1633 +0,0 @@ -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/new/Text/Mod/Mappers.txt b/new/Text/Mod/Mappers.txt deleted file mode 100644 index f0fc9b7..0000000 --- a/new/Text/Mod/Mappers.txt +++ /dev/null @@ -1,596 +0,0 @@ -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/new/Text/Mod/Models.txt b/new/Text/Mod/Models.txt deleted file mode 100644 index dc1e43b..0000000 --- a/new/Text/Mod/Models.txt +++ /dev/null @@ -1,2085 +0,0 @@ -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/new/Text/Mod/Rulers.txt b/new/Text/Mod/Rulers.txt deleted file mode 100644 index f2faa49..0000000 --- a/new/Text/Mod/Rulers.txt +++ /dev/null @@ -1,1676 +0,0 @@ -(* 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/new/Text/Mod/Setters.txt b/new/Text/Mod/Setters.txt deleted file mode 100644 index 77aab8b..0000000 --- a/new/Text/Mod/Setters.txt +++ /dev/null @@ -1,1313 +0,0 @@ -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/new/Text/Mod/Views.txt b/new/Text/Mod/Views.txt deleted file mode 100644 index 2ee55ea..0000000 --- a/new/Text/Mod/Views.txt +++ /dev/null @@ -1,1579 +0,0 @@ -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/new/_LinuxOpenBSD_/Host/Mod/Lang.txt b/new/_LinuxOpenBSD_/Host/Mod/Lang.txt deleted file mode 100644 index c565553..0000000 --- a/new/_LinuxOpenBSD_/Host/Mod/Lang.txt +++ /dev/null @@ -1,121 +0,0 @@ -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/new/_LinuxOpenBSD_/Host/Mod/TextConv.txt b/new/_LinuxOpenBSD_/Host/Mod/TextConv.txt deleted file mode 100644 index f539a8f..0000000 --- a/new/_LinuxOpenBSD_/Host/Mod/TextConv.txt +++ /dev/null @@ -1,1155 +0,0 @@ -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/new/_LinuxOpenBSD_/System/Mod/Config.txt b/new/_LinuxOpenBSD_/System/Mod/Config.txt deleted file mode 100644 index bc2049e..0000000 --- a/new/_LinuxOpenBSD_/System/Mod/Config.txt +++ /dev/null @@ -1,27 +0,0 @@ -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/new/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt b/new/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt deleted file mode 100644 index bb5bba2..0000000 --- a/new/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt +++ /dev/null @@ -1,27 +0,0 @@ -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/new/_Linux_/Host/Mod/Console.odc b/new/_Linux_/Host/Mod/Console.odc index 8b94bed..51590a7 100644 Binary files a/new/_Linux_/Host/Mod/Console.odc and b/new/_Linux_/Host/Mod/Console.odc differ diff --git a/new/_Linux_/Host/Mod/Console.txt b/new/_Linux_/Host/Mod/Console.txt deleted file mode 100644 index da1e9a5..0000000 --- a/new/_Linux_/Host/Mod/Console.txt +++ /dev/null @@ -1,156 +0,0 @@ -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/new/_Linux_/Host/Mod/Dates.txt b/new/_Linux_/Host/Mod/Dates.txt deleted file mode 100644 index 16e8621..0000000 --- a/new/_Linux_/Host/Mod/Dates.txt +++ /dev/null @@ -1,92 +0,0 @@ -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/new/_Linux_/Host/Mod/Files.txt b/new/_Linux_/Host/Mod/Files.txt deleted file mode 100644 index 3aa3382..0000000 --- a/new/_Linux_/Host/Mod/Files.txt +++ /dev/null @@ -1,1501 +0,0 @@ -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/new/_Linux_/libBB.so b/new/_Linux_/libBB.so index 3fff21a..45d34c3 100644 Binary files a/new/_Linux_/libBB.so and b/new/_Linux_/libBB.so differ diff --git a/new/_Linux_/libBB0.so b/new/_Linux_/libBB0.so index 8702c82..af998b7 100644 Binary files a/new/_Linux_/libBB0.so and b/new/_Linux_/libBB0.so differ diff --git a/new/_OpenBSD_/Host/Mod/Console.odc b/new/_OpenBSD_/Host/Mod/Console.odc index 74fe243..2c44d6c 100644 Binary files a/new/_OpenBSD_/Host/Mod/Console.odc and b/new/_OpenBSD_/Host/Mod/Console.odc differ diff --git a/new/_OpenBSD_/Host/Mod/Console.txt b/new/_OpenBSD_/Host/Mod/Console.txt deleted file mode 100644 index 5bbb69e..0000000 --- a/new/_OpenBSD_/Host/Mod/Console.txt +++ /dev/null @@ -1,156 +0,0 @@ -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/new/_OpenBSD_/Host/Mod/Dates.txt b/new/_OpenBSD_/Host/Mod/Dates.txt deleted file mode 100644 index 1246d0a..0000000 --- a/new/_OpenBSD_/Host/Mod/Dates.txt +++ /dev/null @@ -1,92 +0,0 @@ -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/new/_OpenBSD_/Host/Mod/Files.txt b/new/_OpenBSD_/Host/Mod/Files.txt deleted file mode 100644 index e4baa8d..0000000 --- a/new/_OpenBSD_/Host/Mod/Files.txt +++ /dev/null @@ -1,1501 +0,0 @@ -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/new/_OpenBSD_/Lin/Mod/Dl.txt b/new/_OpenBSD_/Lin/Mod/Dl.txt index 8213f44..79c595d 100644 --- a/new/_OpenBSD_/Lin/Mod/Dl.txt +++ b/new/_OpenBSD_/Lin/Mod/Dl.txt @@ -1,4 +1,4 @@ -MODULE LinDl ["libdlobsdwrap.so"]; +MODULE LinDl ["ld.so"]; (* A. V. Shiryaev, 2012.09 @@ -26,10 +26,10 @@ MODULE LinDl ["libdlobsdwrap.so"]; 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] dlopen* (file: PtrSTR; mode: INTEGER): HANDLE; + PROCEDURE [ccall] dlclose* (handle: HANDLE): INTEGER; + PROCEDURE [ccall] dlsym* (handle: HANDLE; symbol: PtrSTR): HANDLE; - PROCEDURE [ccall] dlerror* ["__dlerror"] (): PtrSTR; + PROCEDURE [ccall] dlerror* (): PtrSTR; END LinDl. diff --git a/new/_OpenBSD_/System/Mod/Kernel.txt b/new/_OpenBSD_/System/Mod/Kernel.txt deleted file mode 100644 index 2ae9304..0000000 --- a/new/_OpenBSD_/System/Mod/Kernel.txt +++ /dev/null @@ -1,2155 +0,0 @@ -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(65536, N, prot) END; - IF adr = 0 THEN adr := HeapAlloc(65536, 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("---- siginfo: ------------------"); WriteLn; - - KV("signo", siginfo.si_signo); WriteString(", "); - KV("code", siginfo.si_code); WriteString(", "); - KV("errno", siginfo.si_errno); WriteLn; - KV("fault.addr", siginfo._data._fault._addr); WriteString(", "); - KV("fault.trapno", siginfo._data._fault._trapno); WriteLn; - - 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._data._fault._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: ?????? *) - (* 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/new/_OpenBSD_/libBB.so b/new/_OpenBSD_/libBB.so index 5066baa..300bfe3 100644 Binary files a/new/_OpenBSD_/libBB.so and b/new/_OpenBSD_/libBB.so differ diff --git a/new/_OpenBSD_/libBB0.so b/new/_OpenBSD_/libBB0.so index 351327c..6782d14 100644 Binary files a/new/_OpenBSD_/libBB0.so and b/new/_OpenBSD_/libBB0.so differ diff --git a/new/_Windows_/Host/Mod/Console.txt b/new/_Windows_/Host/Mod/Console.txt deleted file mode 100644 index 81f0456..0000000 --- a/new/_Windows_/Host/Mod/Console.txt +++ /dev/null @@ -1,120 +0,0 @@ -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/new/__Interp/Host/Mod/Dialog.odc b/new/__Interp/Host/Mod/Dialog.odc new file mode 100644 index 0000000..e30056a Binary files /dev/null and b/new/__Interp/Host/Mod/Dialog.odc differ diff --git a/new/__Interp/Host/Mod/Dialog.txt b/new/__Interp/Host/Mod/Dialog.txt deleted file mode 100644 index 6dc303e..0000000 --- a/new/__Interp/Host/Mod/Dialog.txt +++ /dev/null @@ -1,52 +0,0 @@ -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/new/__Interp/Host/Mod/Fonts.odc b/new/__Interp/Host/Mod/Fonts.odc new file mode 100644 index 0000000..f6e822b Binary files /dev/null and b/new/__Interp/Host/Mod/Fonts.odc differ diff --git a/new/__Interp/Host/Mod/Fonts.txt b/new/__Interp/Host/Mod/Fonts.txt deleted file mode 100644 index 28d3f96..0000000 --- a/new/__Interp/Host/Mod/Fonts.txt +++ /dev/null @@ -1,75 +0,0 @@ -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/new/__Interp/Host/Mod/Windows.odc b/new/__Interp/Host/Mod/Windows.odc new file mode 100644 index 0000000..8844401 Binary files /dev/null and b/new/__Interp/Host/Mod/Windows.odc differ diff --git a/new/__Interp/Host/Mod/Windows.txt b/new/__Interp/Host/Mod/Windows.txt deleted file mode 100644 index 4200630..0000000 --- a/new/__Interp/Host/Mod/Windows.txt +++ /dev/null @@ -1,143 +0,0 @@ -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/new/__Interp/System/Mod/Init.odc b/new/__Interp/System/Mod/Init.odc new file mode 100644 index 0000000..3f3444d Binary files /dev/null and b/new/__Interp/System/Mod/Init.odc differ diff --git a/new/__Interp/System/Mod/Init.txt b/new/__Interp/System/Mod/Init.txt deleted file mode 100644 index 0d56a57..0000000 --- a/new/__Interp/System/Mod/Init.txt +++ /dev/null @@ -1,28 +0,0 @@ -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/new/build b/new/build index d0e5223..6592f02 100755 --- a/new/build +++ b/new/build @@ -1,123 +1,54 @@ #!/bin/sh ./run-dev0 <