summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 4d118bc)
raw | patch | inline | side by side (parent: 4d118bc)
| author | Alexander Shiryaev <aixp@mail.ru> | |
| Fri, 16 Nov 2012 19:47:16 +0000 (23:47 +0400) | ||
| committer | Alexander Shiryaev <aixp@mail.ru> | |
| Fri, 16 Nov 2012 19:47:16 +0000 (23:47 +0400) |
174 files changed:
diff --git a/new/Cons/Mod/Interp.odc b/new/Cons/Mod/Interp.odc
new file mode 100644 (file)
index 0000000..0b5e294
Binary files /dev/null and b/new/Cons/Mod/Interp.odc differ
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
--- 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 (file)
index 0000000..722604d
Binary files /dev/null and b/new/Cons/Mod/Log.odc differ
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
--- 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 (file)
index 0000000..9b48385
Binary files /dev/null and b/new/Dev/Mod/CPB.odc differ
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
--- 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 (file)
index 0000000..39ba9a5
Binary files /dev/null and b/new/Dev/Mod/CPC486.odc differ
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
--- 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 (file)
index 0000000..f5992b5
Binary files /dev/null and b/new/Dev/Mod/CPE.odc differ
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
--- 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 (file)
index 0000000..70c43c0
Binary files /dev/null and b/new/Dev/Mod/CPH.odc differ
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
--- 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 (file)
index 0000000..7300aa8
Binary files /dev/null and b/new/Dev/Mod/CPL486.odc differ
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
--- 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 (file)
index 0000000..5473454
Binary files /dev/null and b/new/Dev/Mod/CPM.odc differ
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
--- 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 (file)
index 0000000..640c207
Binary files /dev/null and b/new/Dev/Mod/CPP.odc differ
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
--- 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 (file)
index 0000000..83b38d9
Binary files /dev/null and b/new/Dev/Mod/CPS.odc differ
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
--- 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 (file)
index 0000000..af6dab3
Binary files /dev/null and b/new/Dev/Mod/CPT.odc differ
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
--- 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 (file)
index 0000000..d90a3a8
Binary files /dev/null and b/new/Dev/Mod/CPV486.odc differ
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
--- 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 (file)
index 0000000..59aaf0a
Binary files /dev/null and b/new/Dev/Mod/Commanders.odc differ
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
+++ /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 (file)
index 0000000..1e1bb53
Binary files /dev/null and b/new/Dev/Mod/Compiler.odc differ
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
--- 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 (file)
index 0000000..f3efde2
Binary files /dev/null and b/new/Dev/Mod/Markers.odc differ
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
--- 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 (file)
index 0000000..93231d7
Binary files /dev/null and b/new/Dev/Mod/Selectors.odc differ
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
+++ /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 (file)
index 6446649..0000000
Binary files a/new/Dev0/Mod/CPB.odc and /dev/null differ
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
--- 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 (file)
index 4c05887..0000000
Binary files a/new/Dev0/Mod/CPC486.odc and /dev/null differ
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
--- 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 (file)
index 3d1952b..0000000
Binary files a/new/Dev0/Mod/CPE.odc and /dev/null differ
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
--- 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 (file)
index 4dcb383..0000000
Binary files a/new/Dev0/Mod/CPH.odc and /dev/null differ
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
--- 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 (file)
index b96a99c..0000000
Binary files a/new/Dev0/Mod/CPL486.odc and /dev/null differ
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
--- 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 (file)
index 0049d01..0000000
Binary files a/new/Dev0/Mod/CPM.odc and /dev/null differ
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
--- 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 (file)
index 0cd6ae1..0000000
Binary files a/new/Dev0/Mod/CPP.odc and /dev/null differ
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
--- 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 (file)
index 8548317..0000000
Binary files a/new/Dev0/Mod/CPS.odc and /dev/null differ
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
--- 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 (file)
index a858cbb..0000000
Binary files a/new/Dev0/Mod/CPT.odc and /dev/null differ
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
--- 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 (file)
index 3e32c73..0000000
Binary files a/new/Dev0/Mod/CPV486.odc and /dev/null differ
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
--- 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 (file)
index 8449f33..0000000
Binary files a/new/Dev0/Mod/Compiler.odc and /dev/null differ
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
+++ /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 (file)
index 0b74d87..0000000
Binary files a/new/Dev0/Mod/ElfLinker16.odc and /dev/null differ
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
+++ /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
--- 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 (file)
index d07ac20..0000000
Binary files a/new/Dev0/Mod/Linker.odc and /dev/null differ
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
--- 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
--- 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 (file)
index 0000000..a4f7a6b
Binary files /dev/null and b/new/Std/Mod/Api.odc differ
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 (file)
index 0000000..bfb5b5b
Binary files /dev/null and b/new/Std/Mod/CFrames.odc differ
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 (file)
index 0000000..49e0389
Binary files /dev/null and b/new/Std/Mod/Clocks.odc differ
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 (file)
index 0000000..49bee1e
Binary files /dev/null and b/new/Std/Mod/Cmds.odc differ
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 (file)
index 0000000..e8cdd96
Binary files /dev/null and b/new/Std/Mod/Coder.odc differ
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 (file)
index 0000000..6be64ec
Binary files /dev/null and b/new/Std/Mod/Debug.odc differ
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 (file)
index 0000000..799397f
Binary files /dev/null and b/new/Std/Mod/Dialog.odc differ
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 (file)
index 0000000..28d446c
Binary files /dev/null and b/new/Std/Mod/ETHConv.odc differ
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 (file)
index 0000000..7e50952
Binary files /dev/null and b/new/Std/Mod/Folds.odc differ
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 (file)
index 0000000..de4be99
Binary files /dev/null and b/new/Std/Mod/Headers.odc differ
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 (file)
index 0000000..c94801b
Binary files /dev/null and b/new/Std/Mod/Interpreter.odc differ
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 (file)
index 0000000..609a250
Binary files /dev/null and b/new/Std/Mod/Links.odc differ
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 (file)
index 0000000..4dc2274
Binary files /dev/null and b/new/Std/Mod/Loader.odc differ
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 (file)
index 0000000..c868963
Binary files /dev/null and b/new/Std/Mod/Log.odc differ
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 (file)
index 0000000..f06491f
Binary files /dev/null and b/new/Std/Mod/Logos.odc differ
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 (file)
index 0000000..7791b17
Binary files /dev/null and b/new/Std/Mod/Scrollers.odc differ
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 (file)
index 0000000..5c18847
Binary files /dev/null and b/new/Std/Mod/Stamps.odc differ
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 (file)
index 0000000..17dd55c
Binary files /dev/null and b/new/Std/Mod/ViewSizer.odc differ
index 0000000..17dd55c
Binary files /dev/null and b/new/Std/Mod/ViewSizer.odc differ
diff --git a/new/System/Mod/Console.txt b/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 (file)
index 0000000..40fba97
Binary files /dev/null and b/new/System/Mod/Containers.odc differ
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
+++ /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 (file)
index 0000000..69a7a38
Binary files /dev/null and b/new/System/Mod/Controllers.odc differ
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
+++ /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 (file)
index 0000000..0abca3c
Binary files /dev/null and b/new/System/Mod/Controls.odc differ
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
+++ /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 (file)
index 0000000..753d0fb
Binary files /dev/null and b/new/System/Mod/Converters.odc differ
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
+++ /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 (file)
index 0000000..e7e5097
Binary files /dev/null and b/new/System/Mod/Dates.odc differ
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
--- 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 (file)
index 0000000..63378db
Binary files /dev/null and b/new/System/Mod/Dialog.odc differ
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
+++ /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 (file)
index 0000000..b7c2489
Binary files /dev/null and b/new/System/Mod/Documents.odc differ
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
+++ /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 (file)
index 0000000..fb44f00
Binary files /dev/null and b/new/System/Mod/Files.odc differ
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
--- 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 (file)
index 0000000..5752b8c
Binary files /dev/null and b/new/System/Mod/Fonts.odc differ
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
--- 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/System/Mod/In.txt b/new/System/Mod/In.txt
--- 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 (file)
index 0000000..bd9d450
Binary files /dev/null and b/new/System/Mod/Integers.odc differ
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
+++ /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 (file)
index 0000000..6844660
Binary files /dev/null and b/new/System/Mod/Log.odc differ
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
--- 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 (file)
index 0000000..e3c48ec
Binary files /dev/null and b/new/System/Mod/Math.odc differ
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
--- 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 (file)
index 0000000..b4c0d86
Binary files /dev/null and b/new/System/Mod/Mechanisms.odc differ
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
+++ /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 (file)
index 0000000..d294ff3
Binary files /dev/null and b/new/System/Mod/Meta.odc differ
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
--- 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 (file)
index 0000000..179464f
Binary files /dev/null and b/new/System/Mod/Models.odc differ
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
+++ /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/System/Mod/Ports.odc b/new/System/Mod/Ports.odc
new file mode 100644 (file)
index 0000000..12814c6
Binary files /dev/null and b/new/System/Mod/Ports.odc differ
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
--- 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 (file)
index 0000000..07009f9
Binary files /dev/null and b/new/System/Mod/Printers.odc differ
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
+++ /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 (file)
index 0000000..9493e84
Binary files /dev/null and b/new/System/Mod/Printing.odc differ
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
+++ /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 (file)
index 0000000..031291c
Binary files /dev/null and b/new/System/Mod/Properties.odc differ
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
+++ /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 (file)
index 0000000..f5a7706
Binary files /dev/null and b/new/System/Mod/SMath.odc differ
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
--- 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 (file)
index 0000000..024593e
Binary files /dev/null and b/new/System/Mod/Sequencers.odc differ
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
+++ /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 (file)
index 0000000..6fb5caf
Binary files /dev/null and b/new/System/Mod/Services.odc differ
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
+++ /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 (file)
index 0000000..57627ea
Binary files /dev/null and b/new/System/Mod/Stores.odc differ
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
+++ /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 <next> or up block's <down> *)
- 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); (* <comment> *)
- wr.st.linkpos := wr.Pos();
- wr.WriteInt(0) (* <next> *)
- 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); (* <comment> *)
- wr.st.linkpos := wr.Pos();
- wr.WriteInt(0) (* <next> *)
- 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); (* <comment> *)
- pos1 := wr.Pos(); wr.WriteInt(0); wr.WriteInt(0); (* <next>, <down> *)
- pos2 := wr.Pos(); wr.WriteInt(0); (* <len> *)
- 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 <len> *)
- 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 (file)
index 0000000..1c32594
Binary files /dev/null and b/new/System/Mod/Strings.odc differ
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
+++ /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 (file)
index 0000000..f1553bf
Binary files /dev/null and b/new/System/Mod/Views.odc differ
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
--- 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 (file)
index 0000000..425806c
Binary files /dev/null and b/new/System/Mod/Windows.odc differ
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
+++ /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
--- 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
+++ /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
--- 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
--- 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 <first, last> *)
- pos: INTEGER;
- first, last: Run; (* op = moveBuf: move <first, last> to text.pos;
- op = writeView: insert <first> at text.pos*)
- len: INTEGER; (* op = moveBuf: length of <first, last>;
- 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
--- 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
--- 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
--- 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
+++ /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
+++ /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("]\8f\8f\8f")
- END;
- w.WriteIntForm(ORD(ch), TextMappers.hexadecimal, 2, "0", FALSE);
- IF ch > 20X THEN str[a MOD 16] := ch ELSE str[a MOD 16] := "\8f" END;
- INC(a);
- IF a MOD 16 = 0 THEN
- str[16] := 0X; w.WriteString("\8f\8f\8f\8f"); w.WriteString(str);
- w.WriteLn
- ELSIF a MOD 4 = 0 THEN
- w.WriteString("\8f\8f")
- ELSE
- w.WriteChar("\8f")
- 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("\8f"); 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
+++ /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
+++ /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.
index 8b94bedb5d932705bd2d788112abda8e97226d25..51590a7e5302a2dadef834981857a9c7a090790a 100644 (file)
Binary files a/new/_Linux_/Host/Mod/Console.odc and b/new/_Linux_/Host/Mod/Console.odc differ
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
+++ /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
+++ /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
+++ /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 3fff21a3cc86920726c444de1d60d2295516b457..45d34c390cd2b9c0e7ab9099279ce466c097e93b 100644 (file)
Binary files a/new/_Linux_/libBB.so and b/new/_Linux_/libBB.so differ
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 8702c824e848a84b06657633edac2a350ef2465f..af998b7729d54b5fc1b19df68d087ff7f78f0247 100644 (file)
Binary files a/new/_Linux_/libBB0.so and b/new/_Linux_/libBB0.so differ
Binary files a/new/_Linux_/libBB0.so and b/new/_Linux_/libBB0.so differ
index 74fe243379e4611ae4270cecc0e610cea1c43af7..2c44d6c7e78ca06bdb47f823db4a70e8ba54c55f 100644 (file)
Binary files a/new/_OpenBSD_/Host/Mod/Console.odc and b/new/_OpenBSD_/Host/Mod/Console.odc differ
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
+++ /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
+++ /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
+++ /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.
index 8213f445f30a4e90d77d5f3faa529572d420ed4d..79c595d441d9a42213c3523568e4bddb37e3939f 100644 (file)
-MODULE LinDl ["libdlobsdwrap.so"];
+MODULE LinDl ["ld.so"];
(*
A. V. Shiryaev, 2012.09
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
+++ /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 5066baa2f314c0742db5804677c32dba08906533..300bfe31104f7b37cf9b249aec5fb0b40c12773f 100644 (file)
Binary files a/new/_OpenBSD_/libBB.so and b/new/_OpenBSD_/libBB.so differ
Binary files a/new/_OpenBSD_/libBB.so and b/new/_OpenBSD_/libBB.so differ
index 351327c3a45217ab3a57255abe3e69a585b03808..6782d14aeec1032fa727fc56eeaa86eb669bd283 100644 (file)
Binary files a/new/_OpenBSD_/libBB0.so and b/new/_OpenBSD_/libBB0.so differ
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
+++ /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 (file)
index 0000000..e30056a
Binary files /dev/null and b/new/__Interp/Host/Mod/Dialog.odc differ
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
+++ /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 (file)
index 0000000..f6e822b
Binary files /dev/null and b/new/__Interp/Host/Mod/Fonts.odc differ
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
+++ /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 (file)
index 0000000..8844401
Binary files /dev/null and b/new/__Interp/Host/Mod/Windows.odc differ
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
+++ /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 (file)
index 0000000..3f3444d
Binary files /dev/null and b/new/__Interp/System/Mod/Init.odc differ
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
+++ /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 d0e52238c32bf79ce3b629e990fb432bb80b6a26..6592f024af61bdb1210d803b07678a0478e8ad35 100755 (executable)
--- a/new/build
+++ b/new/build
#!/bin/sh
./run-dev0 <<DATA
-Dev0Compiler.Compile('Lin/Mod', 'Dl.txt')
-Dev0Compiler.Compile('Lin/Mod', 'Libc.txt')
-Dev0Compiler.Compile('Lin/Mod', 'Iconv.txt')
-Dev0Compiler.Compile('System/Mod', 'Kernel.txt')
-
-Dev0Compiler.Compile('System/Mod', 'Files.txt')
-Dev0Compiler.Compile('System/Mod', 'Console.txt')
-Dev0Compiler.Compile('System/Mod', 'Math.txt')
-Dev0Compiler.Compile('System/Mod', 'Strings.txt')
-Dev0Compiler.Compile('System/Mod', 'Meta.txt')
-Dev0Compiler.Compile('System/Mod', 'Dialog.txt')
-
-Dev0Compiler.Compile('Host/Mod', 'Lang.txt')
-Dev0Compiler.Compile('Host/Mod', 'Files.txt')
-Dev0Compiler.Compile('Host/Mod', 'Console.txt')
-
-Dev0Compiler.Compile('System/Mod', 'Stores.txt')
-Dev0Compiler.Compile('System/Mod', 'Converters.txt')
-Dev0Compiler.Compile('System/Mod', 'Dates.txt')
-Dev0Compiler.Compile('System/Mod', 'Integers.txt')
-Dev0Compiler.Compile('System/Mod', 'Sequencers.txt')
-Dev0Compiler.Compile('System/Mod', 'Services.txt')
-Dev0Compiler.Compile('System/Mod', 'Log.txt')
-Dev0Compiler.Compile('System/Mod', 'SMath.txt')
-
-Dev0Compiler.Compile('System/Mod', 'Fonts.txt')
-Dev0Compiler.Compile('System/Mod', 'Ports.txt')
-Dev0Compiler.Compile('System/Mod', 'Printers.txt')
-Dev0Compiler.Compile('System/Mod', 'Models.txt')
-Dev0Compiler.Compile('System/Mod', 'Views.txt')
-Dev0Compiler.Compile('System/Mod', 'Printing.txt')
-Dev0Compiler.Compile('System/Mod', 'Mechanisms.txt')
-Dev0Compiler.Compile('System/Mod', 'Controllers.txt')
-Dev0Compiler.Compile('System/Mod', 'Properties.txt')
-Dev0Compiler.Compile('System/Mod', 'Containers.txt')
-Dev0Compiler.Compile('System/Mod', 'Documents.txt')
-Dev0Compiler.Compile('System/Mod', 'Windows.txt')
-
-Dev0Compiler.Compile('Text/Mod', 'Models.txt')
-Dev0Compiler.Compile('Text/Mod', 'Mappers.txt')
-Dev0Compiler.Compile('Text/Mod', 'Rulers.txt')
-Dev0Compiler.Compile('Text/Mod', 'Setters.txt')
-Dev0Compiler.Compile('Text/Mod', 'Views.txt')
-Dev0Compiler.Compile('Text/Mod', 'Controllers.txt')
-Dev0Compiler.Compile('Text/Mod', 'Cmds.txt')
-
-Dev0Compiler.Compile('System/Mod', 'In.txt')
-
-Dev0Compiler.Compile('Std/Mod', 'Dialog.txt')
-Dev0Compiler.Compile('Std/Mod', 'Api.txt')
-Dev0Compiler.Compile('Std/Mod', 'CFrames.txt')
-Dev0Compiler.Compile('System/Mod', 'Controls.txt')
-Dev0Compiler.Compile('Std/Mod', 'Cmds.txt')
-Dev0Compiler.Compile('Std/Mod', 'Logos.txt')
-Dev0Compiler.Compile('Std/Mod', 'Scrollers.txt')
-Dev0Compiler.Compile('Std/Mod', 'ViewSizer.txt')
-
-Dev0Compiler.Compile('Std/Mod', 'Clocks.txt')
-Dev0Compiler.Compile('Std/Mod', 'Coder.txt')
-Dev0Compiler.Compile('Std/Mod', 'Folds.txt')
-Dev0Compiler.Compile('Std/Mod', 'Debug.txt')
-Dev0Compiler.Compile('Std/Mod', 'Stamps.txt')
-Dev0Compiler.Compile('Std/Mod', 'ETHConv.txt')
-Dev0Compiler.Compile('Std/Mod', 'Headers.txt')
-Dev0Compiler.Compile('Std/Mod', 'Links.txt')
-
-Dev0Compiler.Compile('Std/Mod', 'Loader.txt')
-Dev0Compiler.Compile('System/Mod', 'Kernel_so_init.txt')
+ConsCompiler.Compile('Lin/Mod', 'Dl.txt')
+ConsCompiler.Compile('Lin/Mod', 'Libc.txt')
+ConsCompiler.Compile('Lin/Mod', 'Iconv.txt')
+DevCompiler.CompileThis Kernel
-# before StdLog
-Dev0Compiler.Compile('Host/Mod', 'Dialog.txt')
-
-Dev0Compiler.Compile('Std/Mod', 'Log.txt')
-# Dev0Compiler.Compile('', 'StdLog.txt')
-# Dev0Compiler.Compile('Std/Mod', 'Out.txt')
-Dev0Compiler.Compile('Cons/Mod', 'Log.txt')
-
-Dev0Compiler.Compile('Dev/Mod', 'Markers.txt')
-Dev0Compiler.Compile('Dev/Mod', 'Commanders.txt')
-Dev0Compiler.Compile('Dev/Mod', 'Selectors.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPM.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPT.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPH.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPB.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPE.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPS.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPP.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPL486.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPC486.txt')
-Dev0Compiler.Compile('Dev/Mod', 'CPV486.txt')
-Dev0Compiler.Compile('Dev/Mod', 'Compiler.txt')
-# Dev0Compiler.Compile('Dev/Mod', 'ElfLinker16.txt')
-
-Dev0Compiler.Compile('Std/Mod', 'Interpreter.txt')
+DevCompiler.CompileThis Files Console Math Strings Meta Dialog
-### BlackBox
+DevCompiler.CompileThis HostLang HostFiles HostConsole
-Dev0Compiler.Compile('Host/Mod', 'Fonts.txt')
-Dev0Compiler.Compile('Host/Mod', 'Windows.txt')
-Dev0Compiler.Compile('Host/Mod', 'Dates.txt')
-Dev0Compiler.Compile('Host/Mod', 'TextConv.txt')
+DevCompiler.CompileThis Stores Converters Dates Integers Sequencers Services Log SMath
-Dev0Compiler.Compile('Cons/Mod', 'Interp.txt')
+DevCompiler.CompileThis Fonts Ports Printers Models Views Printing Mechanisms Controllers Properties Containers Documents Windows
-Dev0Compiler.Compile('System/Mod', 'Init.txt')
-Dev0Compiler.Compile('System/Mod', 'Config.txt')
+DevCompiler.CompileThis TextModels TextMappers TextRulers TextSetters TextViews TextControllers TextCmds
-Dev0ElfLinker.LinkDll('libBB.so := Kernel+ Files HostFiles StdLoader')
-# Dev0ElfLinker.LinkDll('libBB.so := Kernel+ Kernel_so_init# Files HostFiles StdLoader')
-DATA
+DevCompiler.CompileThis In
+
+DevCompiler.CompileThis StdDialog StdApi StdCFrames Controls StdCmds StdLogos StdScrollers StdViewSizer
+
+DevCompiler.CompileThis StdClocks StdCoder StdFolds StdDebug StdStamps StdETHConv StdHeaders StdLinks
+
+DevCompiler.CompileThis StdLoader
+DevCompiler.CompileThis Kernel_so_init
+
+# before StdLog
+DevCompiler.CompileThis HostDialog
+
+DevCompiler.CompileThis StdLog
+DevCompiler.CompileThis Out
+DevCompiler.CompileThis ConsLog
-./run-BlackBox <<DATA
-DevCompiler.CompileThis DevElfLinker16
+DevCompiler.CompileThis DevMarkers DevCommanders DevSelectors DevCPM DevCPT DevCPH DevCPB DevCPE DevCPS DevCPP DevCPL486 DevCPC486 DevCPV486 DevCompiler DevElfLinker16 DevLinker
DevCompiler.CompileThis ConsCompiler
-DATA
-./run-BlackBox <<DATA
+DevCompiler.CompileThis StdInterpreter
+
+### BlackBox
+
+DevCompiler.CompileThis HostFonts HostWindows
+DevCompiler.CompileThis HostDates
+DevCompiler.CompileThis HostTextConv
+
+DevCompiler.CompileThis ConsInterp
+
+DevCompiler.CompileThis Init Config
+
+DevElfLinker.LinkDll libBB.so := Kernel+ Files HostFiles StdLoader
+
DevCompiler.CompileThis HostPackedFiles DevPacker
DevCompiler.CompileThis CommStreams
diff --git a/new/build-dev0 b/new/build-dev0
--- a/new/build-dev0
+++ /dev/null
@@ -1,43 +0,0 @@
-#!/bin/sh
-
-./run-dev0 <<DATA
-Dev0Compiler.Compile('Lin/Mod', 'Dl.txt')
-Dev0Compiler.Compile('Lin/Mod', 'Libc.txt')
-Dev0Compiler.Compile('Lin/Mod', 'Iconv.txt')
-Dev0Compiler.Compile('System/Mod', 'Kernel.txt')
-
-Dev0Compiler.Compile('System/Mod', 'Files.txt')
-Dev0Compiler.Compile('System/Mod', 'Console.txt')
-Dev0Compiler.Compile('System/Mod', 'Math.txt')
-Dev0Compiler.Compile('System/Mod', 'Strings.txt')
-Dev0Compiler.Compile('System/Mod', 'Meta.txt')
-Dev0Compiler.Compile('System/Mod', 'Dialog.txt')
-
-Dev0Compiler.Compile('Dev0/Mod', 'CPM.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPT.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPS.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPH.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPB.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPP.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPE.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPL486.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPC486.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'CPV486.txt')
-
-Dev0Compiler.Compile('Dev0/Mod', 'Compiler.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'ElfLinker16.txt')
-Dev0Compiler.Compile('Dev0/Mod', 'Linker.txt')
-
-Dev0Compiler.Compile('Host/Mod', 'Lang.txt')
-Dev0Compiler.Compile('Host/Mod', 'Files.txt')
-Dev0Compiler.Compile('Host/Mod', 'Console.txt')
-
-### simple dev interpreter (include Dev0Compiler, Dev0ElfLinker)
-
-Dev0Compiler.Compile('Dev0', 'Views.txt')
-Dev0Compiler.Compile('Std/Mod', 'Interpreter.txt')
-
-Dev0Compiler.Compile('Dev0/Mod', 'Interp.txt')
-
-Dev0ElfLinker.LinkDll('libBB0.so := Kernel+ Files HostFiles Console Math Strings Dev0CPM Dev0CPT Dev0CPS Dev0CPH Dev0CPB Dev0CPP Dev0CPE Dev0CPL486 Dev0CPC486 Dev0CPV486 Dev0Compiler Dev0ElfLinker Dialog Meta Views StdInterpreter HostLang HostConsole Dev0Interp')
-DATA
diff --git a/new/build-gui b/new/build-gui
index 9461d10f915c351d494eb5988215fa4172c7a801..c14316bcac153fd05dc7c4b8a6ddaefdbc64b503 100755 (executable)
--- a/new/build-gui
+++ b/new/build-gui
DevCompiler.CompileThis DevAlienTool DevDebug DevDependencies DevHeapSpy DevInspector DevLinkChk DevMsgSpy DevRBrowser DevReferences DevSearch DevSubTool DevCmds DevBrowser
-DevCompiler.CompileThis In Out
-
DevCompiler.CompileThis ObxActions ObxAddress0 ObxAddress1 ObxAddress2 ObxAscii ObxBlackBox ObxButtons ObxCalc ObxCaps ObxContIter ObxControlShifter ObxControls ObxConv ObxCount0 ObxCount1 ObxCubes ObxDb ObxDialog ObxFact ObxFileTree ObxFldCtrls ObxGraphs ObxHello1 ObxLabelLister ObxLines ObxLinks ObxMMerge ObxOmosi ObxOpen0 ObxOpen1 ObxOrders ObxParCmd ObxPatterns ObxRatcalc ObxSample ObxScroll ObxStores ObxTabViews ObxTabs ObxTickers ObxTwins ObxUnitConv ObxViews0 ObxViews1 ObxViews10 ObxViews11 ObxViews12 ObxViews13 ObxViews14 ObxViews2 ObxViews3 ObxViews4 ObxViews5 ObxViews6 ObxWrappers
DevCompiler.CompileThis ObxPhoneDB ObxPhoneUI ObxPhoneUI1 ObxLookup0 ObxLookup1 ObxPDBRep0 ObxPDBRep1 ObxPDBRep2 ObxPDBRep3 ObxPDBRep4
diff --git a/new/pack-dev0 b/new/pack-dev0
--- /dev/null
+++ b/new/pack-dev0
@@ -0,0 +1,10 @@
+#!/bin/sh
+
+./run-BlackBox <<DATA
+# DevElfLinker.LinkDll libBB0.so := Kernel+ Files HostFiles HostPackedFiles StdLoader
+# DevPacker.PackThis libBB0.so := Code/Init.ocf Host/Code/Console.ocf Code/Console.ocf Host/Code/Lang.ocf Code/Dialog.ocf Host/Code/Fonts.ocf Code/Fonts.ocf Host/Code/Windows.ocf Code/Windows.ocf Code/Ports.ocf Code/Services.ocf Code/Stores.ocf Code/Strings.ocf Code/Math.ocf Code/Sequencers.ocf Code/Models.ocf Code/Views.ocf Code/Log.ocf Code/Converters.ocf Code/Meta.ocf Code/Controllers.ocf Code/Properties.ocf Code/Containers.ocf Code/Mechanisms.ocf Code/Documents.ocf Code/Dates.ocf Code/Printers.ocf Code/Printing.ocf Host/Code/Dates.ocf Host/Code/Dialog.ocf Std/Code/Interpreter.ocf Std/Code/Dialog.ocf Std/Code/Log.ocf Text/Code/Models.ocf Text/Code/Mappers.ocf Text/Code/Rulers.ocf Text/Code/Views.ocf Text/Code/Setters.ocf Text/Code/Controllers.ocf Cons/Code/Log.ocf Code/Config.ocf Cons/Code/Interp.ocf Dev/Code/Commanders.ocf Code/Controls.ocf Std/Code/CFrames.ocf Dev/Code/Compiler.ocf Dev/Code/Markers.ocf Dev/Code/Selectors.ocf Dev/Code/CPM.ocf Dev/Code/CPT.ocf Dev/Code/CPB.ocf Dev/Code/CPP.ocf Dev/Code/CPS.ocf Dev/Code/CPE.ocf Dev/Code/CPV486.ocf Dev/Code/CPH.ocf Dev/Code/CPL486.ocf Dev/Code/CPC486.ocf Std/Code/ETHConv.ocf Host/Code/TextConv.ocf Dev/Code/ElfLinker.ocf Dev/Code/Linker.ocf Cons/Code/Compiler.ocf ~
+
+# link instead of pack OS-specifics
+DevElfLinker.LinkDll libBB0.so := Kernel+ Files HostFiles HostPackedFiles Console Dialog HostLang HostConsole Dates HostDates StdLoader
+DevPacker.PackThis libBB0.so := Code/Init.ocf Host/Code/Fonts.ocf Code/Fonts.ocf Host/Code/Windows.ocf Code/Windows.ocf Code/Ports.ocf Code/Services.ocf Code/Stores.ocf Code/Strings.ocf Code/Math.ocf Code/Sequencers.ocf Code/Models.ocf Code/Views.ocf Code/Log.ocf Code/Converters.ocf Code/Meta.ocf Code/Controllers.ocf Code/Properties.ocf Code/Containers.ocf Code/Mechanisms.ocf Code/Documents.ocf Code/Printers.ocf Code/Printing.ocf Host/Code/Dialog.ocf Std/Code/Interpreter.ocf Std/Code/Dialog.ocf Std/Code/Log.ocf Text/Code/Models.ocf Text/Code/Mappers.ocf Text/Code/Rulers.ocf Text/Code/Views.ocf Text/Code/Setters.ocf Text/Code/Controllers.ocf Cons/Code/Log.ocf Code/Config.ocf Cons/Code/Interp.ocf Dev/Code/Commanders.ocf Code/Controls.ocf Std/Code/CFrames.ocf Dev/Code/Compiler.ocf Dev/Code/Markers.ocf Dev/Code/Selectors.ocf Dev/Code/CPM.ocf Dev/Code/CPT.ocf Dev/Code/CPB.ocf Dev/Code/CPP.ocf Dev/Code/CPS.ocf Dev/Code/CPE.ocf Dev/Code/CPV486.ocf Dev/Code/CPH.ocf Dev/Code/CPL486.ocf Dev/Code/CPC486.ocf Std/Code/ETHConv.ocf Host/Code/TextConv.ocf Dev/Code/ElfLinker.ocf Dev/Code/Linker.ocf Cons/Code/Compiler.ocf ~
+DATA