Oberon/V2/Texts.Mod

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.