Oberon/V2/Texts.Mod
< Oberon
MODULE Texts; (*JG 21.11.90*)
IMPORT Files, Fonts, Reals;
CONST
(*symbol classes*)
Inval* = 0; (*invalid symbol*)
Name* = 1; (*name s (length len)*)
String* = 2; (*literal string s (length len)*)
Int* = 3; (*integer i (decimal or hexadecimal)*)
Real* = 4; (*real number x*)
LongReal* = 5; (*long real number y*)
Char* = 6; (*special character c*)
TAB = 9X; CR = 0DX; maxD = 9;
(* TextBlock = TextBlockId off run {run} 0 len {AsciiCode}.
run = fnt [name] col voff len. *)
TextBlockId = 1FFH;
replace* = 0; insert* = 1; delete* = 2; (*op-codes*)
TYPE
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD
f: Files.File;
off: LONGINT;
len: LONGINT;
fnt: Fonts.Font;
col: SHORTINT;
voff: SHORTINT;
prev, next: Piece
END;
Text* = POINTER TO TextDesc;
Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
TextDesc* = RECORD
len*: LONGINT;
notify*: Notifier;
trailer: Piece;
org: LONGINT; (*cache*)
pce: Piece
END;
Reader* = RECORD (Files.Rider)
eot*: BOOLEAN;
fnt*: Fonts.Font;
col*: SHORTINT;
voff*: SHORTINT;
ref: Piece;
org: LONGINT;
off: LONGINT
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*: INTEGER;
class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT;
s*: ARRAY 32 OF CHAR
END;
Buffer* = POINTER TO BufDesc;
BufDesc* = RECORD
len*: LONGINT;
header, last: Piece
END;
Writer* = RECORD (Files.Rider)
buf*: Buffer;
fnt*: Fonts.Font;
col*: SHORTINT;
voff*: SHORTINT
END;
VAR W: Writer; WFile: Files.File; DelBuf: Buffer;
PROCEDURE EQ (VAR s, t: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN i := 0;
WHILE (s[i] # 0X) & (t[i] # 0X) & (s[i] = t[i]) DO INC(i) END;
RETURN s[i] = t[i]
END EQ;
PROCEDURE ReadName (VAR R: Files.Rider; VAR name: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN
i := 0; Files.Read(R, ch);
WHILE ch # 0X DO name[i] := ch; INC(i); Files.Read(R, ch) END;
name[i] := 0X
END ReadName;
PROCEDURE WriteName (VAR W: Files.Rider; VAR name: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN
i := 0; ch := name[i];
WHILE ch # 0X DO Files.Write(W, ch); INC(i); ch := name[i] END;
Files.Write(W, 0X)
END WriteName;
PROCEDURE Load* (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
VAR
R: Files.Rider;
Q, q, p: Piece;
off: LONGINT;
N, fnt: SHORTINT;
FName: ARRAY 32 OF CHAR;
Dict: ARRAY 32 OF Fonts.Font;
BEGIN
N := 1;
NEW(Q); Q.f := WFile; Q.off := 0; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; p := Q;
Files.Set(R, f, pos); Files.ReadBytes(R, off, 4);
LOOP
Files.Read(R, fnt);
IF fnt = 0 THEN EXIT END;
IF fnt = N THEN
ReadName(R, FName);
Dict[N] := Fonts.This(FName);
INC(N)
END;
NEW(q);
q.fnt := Dict[fnt];
Files.Read(R, q.col);
Files.Read(R, q.voff);
Files.ReadBytes(R, q.len, 4);
q.f := f; q.off := off;
off := off + q.len;
p.next := q; q.prev := p; p := q
END;
p.next := Q; Q.prev := p;
T.trailer := Q; Files.ReadBytes(R, T.len, 4);
T.org := -1; T.pce := T.trailer; (*init cache*)
len := off - pos
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; R: Files.Rider; Q, q: Piece;
id: INTEGER; len: LONGINT;
BEGIN
f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.ReadBytes(R, id, 2);
IF id = TextBlockId THEN Load(T, f, 2, len)
ELSE (*Ascii file*)
len := Files.Length(f);
NEW(Q); Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile; Q.off := 0; Q.len := 1;
NEW(q); q.fnt := Fonts.Default; q.col := 15; q.voff := 0; q.f := f; q.off := 0; q.len := len;
Q.next := q; q.prev := Q; q.next := Q; Q.prev := q;
T.trailer := Q; T.len := len;
T.org := -1; T.pce := T.trailer (*init cache*)
END
ELSE (*create new text*)
NEW(Q); Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile; Q.off := 0; Q.len := 1;
Q.next := Q; Q.prev := Q;
T.trailer := Q; T.len := 0;
T.org := -1; T.pce := T.trailer (*init cache*)
END
END Open;
PROCEDURE OpenBuf* (B: Buffer);
BEGIN NEW(B.header); (*null piece*)
B.last := B.header; B.len := 0
END OpenBuf;
PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR p: Piece);
VAR n: INTEGER;
BEGIN
IF pos < T.org THEN T.org := -1; T.pce := T.trailer END;
org := T.org; p := T.pce; (*from cache*)
n := 0;
WHILE pos >= org + p.len DO org := org + p.len; p := p.next; INC(n) END;
IF n > 50 THEN T.org := org; T.pce := p END
END FindPiece;
PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece);
VAR q: Piece;
BEGIN
IF off > 0 THEN NEW(q);
q.fnt := p.fnt; q.col := p.col; q.voff := p.voff;
q.len := p.len - off;
q.f := p.f; q.off := p.off + off;
p.len := off;
q.next := p.next; p.next := q;
q.prev := p; q.next.prev := q;
pr := q
ELSE pr := p
END
END SplitPiece;
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR p: Piece; org: LONGINT;
BEGIN
FindPiece(T, pos, org, p);
R.ref := p; R.org := org; R.off := pos - org;
Files.Set(R, R.ref.f, R.ref.off + R.off); R.eot := FALSE
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
BEGIN
Files.Read(R, ch); R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff;
INC(R.off);
IF R.off = R.ref.len THEN
IF R.ref.f = WFile THEN R.eot := TRUE END;
R.org := R.org + R.off; R.off := 0;
R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0;
Files.Set(R, R.ref.f, R.ref.off)
END
END Read;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
PROCEDURE Store* (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
VAR
p, q: Piece;
R: Reader; W: Files.Rider;
off, rlen: LONGINT; id: INTEGER;
N, n: SHORTINT; ch: CHAR;
Dict: ARRAY 32 OF Fonts.Name;
BEGIN
Files.Set(W, f, pos);
id := TextBlockId; Files.WriteBytes(W, id, 2);
Files.WriteBytes(W, off, 4); (*place holder*)
N := 1;
p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; q := p.next;
WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO
rlen := rlen + q.len; q := q.next
END;
Dict[N] := p.fnt.name;
n := 1;
WHILE ~EQ(Dict[n], p.fnt.name) DO INC(n) END;
Files.Write(W, n);
IF n = N THEN WriteName(W, p.fnt.name); INC(N) END;
Files.Write(W, p.col);
Files.Write(W, p.voff);
Files.WriteBytes(W, rlen, 4);
p := q
END;
Files.Write(W, 0); Files.WriteBytes(W, T.len, 4);
off := Files.Pos(W);
OpenReader(R, T, 0); Read(R, ch);
WHILE ~R.eot DO Files.Write(W, ch); Read(R, ch) END;
Files.Set(W, f, pos + 2); Files.WriteBytes(W, off, 4); (*fixup*)
len := off + T.len - pos
END Store;
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR p, q, qb, qe: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p);
NEW(qb); qb^ := p^;
qb.len := qb.len - (beg - org);
qb.off := qb.off + (beg - org);
qe := qb;
WHILE end > org + p.len DO
org := org + p.len; p := p.next;
NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q
END;
qe.next := NIL; qe.len := qe.len - (org + p.len - end);
B.last.next := qb; qb.prev := B.last; B.last := qe;
B.len := B.len + (end - beg)
END Save;
PROCEDURE Copy* (SB, DB: Buffer);
VAR Q, q, p: Piece;
BEGIN
p := SB.header; Q := DB.last;
WHILE p # SB.last DO p := p.next;
NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q
END;
DB.last := Q; DB.len := DB.len + SB.len
END Copy;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff:
SHORTINT);
VAR pb, pe, p: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb);
FindPiece(T, end, org, p); SplitPiece(p, end - org, pe);
p := pb;
REPEAT
IF 0 IN sel THEN p.fnt := fnt END;
IF 1 IN sel THEN p.col := col END;
IF 2 IN sel THEN p.voff := voff END;
p := p.next
UNTIL p = pe;
T.notify(T, replace, beg, end)
END ChangeLooks;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT;
BEGIN
FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr);
IF T.org >= org THEN (*adjust cache*)
T.org := org - p.prev.len; T.pce := p.prev
END;
pl := pr.prev; qb := B.header.next;
IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
& (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN
pl.len := pl.len + qb.len; qb := qb.next
END;
IF qb # NIL THEN qe := B.last;
qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
END;
T.len := T.len + B.len; end := pos + B.len;
B.last := B.header; B.last.next := NIL; B.len := 0;
T.notify(T, insert, pos, end)
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
BEGIN Insert(T, T.len, B)
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT);
VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr);
FindPiece(T, end, orge, pe); SplitPiece(pe, end - orge, per);
IF T.org >= orgb THEN (*adjust cache*)
T.org := orgb - pb.prev.len; T.pce := pb.prev
END;
DelBuf.header.next := pbr; DelBuf.last := per.prev;
DelBuf.last.next := NIL; DelBuf.len := end - beg;
per.prev := pbr.prev; pbr.prev.next := per;
T.len := T.len - DelBuf.len;
T.notify(T, delete, beg, end)
END Delete;
PROCEDURE Recall* (VAR B: Buffer); (*deleted text*)
BEGIN B := DelBuf; NEW(DelBuf); OpenBuf(DelBuf)
END Recall;
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; Read(S, S.nextCh)
END OpenScanner;
(*floating point formats:
x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 32;
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h: SHORTINT;
e: INTEGER; k: LONGINT;
x, f: REAL; y, g: LONGREAL;
d: ARRAY maxD OF CHAR;
PROCEDURE ReadScaleFactor;
BEGIN Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") DO
e := e*10 + ORD(ch) - 30H; Read(S, ch)
END
END ReadScaleFactor;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) THEN EXIT
END ;
Read(S, ch)
END;
IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") THEN (*name*)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL (CAP(ch) > "Z")
OR ("A" > CAP(ch)) & (ch > "9")
OR ("0" > ch) & (ch # ".")
OR (i = 31);
S.s[i] := 0X; S.len := i; S.class := 1
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO
S.s[i] := ch; INC(i); Read(S, ch)
END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
ELSE
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
hex := FALSE; j := 0;
LOOP d[i] := ch; INC(i); Read(S, ch);
IF ch < "0" THEN EXIT END;
IF "9" < ch THEN
IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
ELSE EXIT
END
END
END;
IF ch = "H" THEN (*hex number*)
Read(S, ch); S.class := 3;
IF i-j > 8 THEN j := i-8 END ;
k := ORD(d[j]) - 30H; INC(j);
IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ;
WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ;
IF neg THEN S.i := -k ELSE S.i := k END
ELSIF ch = "." THEN (*read real*)
Read(S, ch); h := i;
WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ;
IF ch = "D" THEN
e := 0; y := 0; g := 1;
REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
ReadScaleFactor;
IF negE THEN
IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END
ELSIF e > 0 THEN
IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END
END ;
IF neg THEN y := -y END ;
S.class := 5; S.y := y
ELSE e := 0; x := 0; f := 1;
REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
IF ch = "E" THEN ReadScaleFactor END ;
IF negE THEN
IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
ELSIF e > 0 THEN
IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
END ;
IF neg THEN x := -x END ;
S.class := 4; S.x := x
END ;
IF hex THEN S.class := 0 END
ELSE (*decimal integer*)
S.class := 3; k := 0;
REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := 0 ELSE S.class := 3 END
END
ELSE S.class := 6;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END;
S.nextCh := ch
END Scan;
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN
NEW(W.buf); OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0;
Files.Set(W, Files.New(""), 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR p: Piece;
BEGIN
IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN
NEW(p);
p.f := Files.Base(W); p.off := Files.Pos(W); p.len := 0;
p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff;
p.next := NIL; W.buf.last.next := p;
p.prev := W.buf.last; W.buf.last := p
END;
Files.Write(W, ch);
INC(W.buf.last.len); INC(W.buf.len)
END Write;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 11 OF CHAR;
BEGIN i := 0;
IF x < 0 THEN
IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN
ELSE DEC(n); x0 := -x
END
ELSE x0 := x
END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e: INTEGER; x0: REAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.Expo(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 255 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
(*there are 2 < n <= 8 digits to be written*)
IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := (e - 127) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
x0 := Reals.Ten(n-1); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
Reals.Convert(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "E");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END WriteReal;
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER; sign: CHAR; x0: REAL;
d: ARRAY maxD OF CHAR;
PROCEDURE seq(ch: CHAR; n: INTEGER);
BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
END seq;
PROCEDURE dig(n: INTEGER);
BEGIN
WHILE n > 0 DO
DEC(i); Write(W, d[i]); DEC(n)
END
END dig;
BEGIN e := Reals.Expo(x);
IF k < 0 THEN k := 0 END;
IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
ELSE e := (e - 127) * 77 DIV 256;
IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (*x >= 1.0, 77/256 = log 2*) x := x/Reals.Ten(e)
ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
(* 1 <= x < 10 *)
IF k+e >= maxD-1 THEN k := maxD-1-e
ELSIF k+e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten(k+e); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN INC(e) END;
(*e = no. of digits before decimal point*)
INC(e); i := k+e; Reals.Convert(x, i, d);
IF e > 0 THEN
seq(" ", n-e-k-2); Write(W, sign); dig(e);
Write(W, "."); dig(k)
ELSE seq(" ", n-k-3);
Write(W, sign); Write(W, "0"); Write(W, ".");
seq("0", -e); dig(k+e)
END
END
END WriteRealFix;
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
VAR i: INTEGER;
d: ARRAY 8 OF CHAR;
BEGIN Reals.ConvertH(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
END WriteRealHex;
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
CONST maxD = 16;
VAR e: INTEGER; x0: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.ExpoL(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 2047 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD;
(*there are 2 <= n <= maxD digits to be written*)
IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := SHORT(LONG(e - 1023) * 77 DIV 256);
IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ;
IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ;
x0 := Reals.TenL(n-1); x := x0*x + 0.5D0;
IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ;
Reals.ConvertL(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "D");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100;
Write(W, CHR(e DIV 10 + 30H));
Write(W, CHR(e MOD 10 + 30H))
END
END WriteLongReal;
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR i: INTEGER;
d: ARRAY 16 OF CHAR;
BEGIN Reals.ConvertHL(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
END WriteLongRealHex;
PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
PROCEDURE WritePair(ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
BEGIN
WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
BEGIN
NEW(DelBuf); OpenBuf(DelBuf);
OpenWriter(W); Write(W, 0X);
WFile := Files.Base(W)
END Texts.