Oberon/A2/Oberon.Texts.Mod
Jump to navigation
Jump to search
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE Texts IN Oberon; (** portable *) (*JG 23.8.94*)
(** The Texts module implements the text abstract data type. Texts are sequences of
characters and objects, with different colors, different fonts, and vertical offsets.
*)
IMPORT Files, Objects, Display, Fonts, Reals IN A2;
CONST
(** Scanner symbol classes.*)
Inval* = 0; (** Invalid symbol. *)
Name* = 1; (** Name s (of length len).*)
String* = 2; (** Quoted 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. *)
Object* = 7; (** Object obj. *)
TAB = 9X; CR = 0DX; LF = 0AX;
OldTextBlockId = 1X; OldTextSpex = 0F0X;
(* TextBlock = TextBlockId type hlen run {run} 0 tlen {AsciiCode} [font block].
run = font [name] col voff len. *)
BufSize = 64;
TYPE
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD
f: Files.File;
off: LONGINT;
len: LONGINT;
obj: Objects.Object;
lib: Objects.Library;
ref: INTEGER; (* ref no in obs lib *)
col: SHORTINT;
voff: SHORTINT;
prev, next: Piece
END;
Text* = POINTER TO TextDesc;
TextDesc* = RECORD (Objects.ObjDesc)
len*: LONGINT; (** Text consists of characters 0 to T.len - 1. *)
obs: Objects.Library; (* Library containing objects located in text. *)
trailer: Piece;
org: LONGINT; (*cache*)
pce: Piece
END;
UpdateMsg* = RECORD (Display.FrameMsg) (** Message broadcast to indicate that part of a text changed. *)
text*: Text; (** The text that changed. *)
beg*, end*, len*: LONGINT (** Change location. *)
END;
Finder* = RECORD (** Finder of (non-character) objects located in text. *)
eot*: BOOLEAN; (** End-of-text reached during search. *)
pos*: LONGINT; (** Offset of Finder in text. *)
T: Text;
ref: Piece
END;
Reader* = RECORD (** Character-wise reader of a text stream. *)
ref: Piece;
T: Text;
org: LONGINT;
off: LONGINT;
R: Files.Rider;
stamp: LONGINT;
buf: ARRAY BufSize OF CHAR;
bufpos, buflen: LONGINT;
lib*: Objects.Library; (** Library of last character/object read. *)
col*: SHORTINT; (** Color index of last character read. *)
voff*: SHORTINT; (** vertical offset of last character read. *)
eot*: BOOLEAN (** Reader has reached end of the text stream. *)
END;
Scanner* = RECORD (Reader) (** Scanner for symbol streams. *)
nextCh*: CHAR; (** Character immediately following the last symbol scanned. *)
line*: INTEGER; (** # carriage returns scanned so far. *)
class*: INTEGER; (** Scan result: Int, Real, String etc. *)
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT; (** Length of name or string scanned. *)
s*: ARRAY 256 OF CHAR;
obj*: Objects.Object
END;
Buffer* = POINTER TO BufDesc; (** Temporary container of text stretches. *)
BufDesc* = RECORD
len*: LONGINT; (** # characters in buffer. *)
header, last: Piece
END;
Writer* = RECORD (** Used to write a stream of textual data in a buffer. *)
R: Files.Rider;
buf*: Buffer; (** Associated buffer. *)
lib*: Objects.Library; (** Current font/library of characters written. *)
col*: SHORTINT; (** Current color of text being written. *)
voff*: SHORTINT (** Current vertical offset of text being written. *)
END;
VAR TextBlockId* (** First character of a text block. *), DocBlockId, NoSpex, NoSpex2, TextSpex: CHAR;
Wfile: Files.File; R: Files.Rider; DelBuf: Buffer; H: Objects.Handler;
nameChars*: ARRAY 256 OF BOOLEAN;
obs: Objects.Library;
(** Load text block from ASCII file f to text T. *)
PROCEDURE LoadAscii* (T: Text; f: Files.File);
VAR Q, q: Piece; len: LONGINT;
BEGIN len := Files.Length(f);
NEW(Q); Q.f := Wfile; Q.off := 0; Q.len := 1; Q.ref := MIN(INTEGER);
Q.lib := NIL; Q.col := 127; Q.voff := 0;
NEW(q); q.f := f; q.off := 0; q.len := len; q.ref := MIN(INTEGER);
q.lib := Fonts.Default; q.col := 15; q.voff := 0;
Q.next := q; q.prev := Q; q.next := Q; Q.prev := q;
T.handle := H; T.obs := NIL;
T.trailer := Q; T.len := len;
T.org := -1; T.pce := T.trailer (*init cache*)
END LoadAscii;
PROCEDURE ReadDocHeader(VAR R: Files.Rider; VAR ch: CHAR);
VAR len: LONGINT; x, y, w, h: INTEGER; name: ARRAY 256 OF CHAR;
BEGIN Files.Read(R, ch);
Files.ReadString(R, name);
Files.ReadInt(R, x); Files.ReadInt(R, y);
Files.ReadInt(R, w); Files.ReadInt(R, h);
Files.Read(R, ch);
IF ch = 0F7X THEN (* skip meta info *)
Files.Read(R, ch);
IF ch = 08X THEN
Files.ReadLInt(R, len); Files.Set(R, Files.Base(R), Files.Pos(R) + len); Files.Read(R, ch)
END
END
END ReadDocHeader;
(** Load text block from file f at position pos to text T (assumes that the text id has been read already). len returns length. *)
PROCEDURE Load* (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
VAR
R, S: Files.Rider;
Q, q, p: Piece;
hlen, tlen, flen, off: LONGINT;
N, lib: SHORTINT;
type, ref, tag: CHAR;
LName: ARRAY 256 OF CHAR;
Dict: ARRAY 64 OF Objects.Library;
i: INTEGER;
BEGIN
NEW(Q); Q.f := Wfile; Q.off := 0; Q.len := 1; Q.ref := MIN(INTEGER);
Q.lib := NIL; Q.col := 127; Q.voff := 0;
p := Q;
Files.Set(R, f, pos);
Files.Read(R, type);
Files.ReadLInt(R, hlen);
Files.Set(S, f, pos - 1 + hlen - 4);
Files.ReadLInt(S, tlen);
IF (type = TextSpex) OR (type = OldTextSpex) THEN T.obs := NIL; flen := 0
ELSE NEW(T.obs); Objects.OpenLibrary(T.obs);
Files.Set(S, f, pos - 1 + hlen + tlen); Files.Read(S, tag);
IF tag = Objects.LibBlockId THEN
Objects.LoadLibrary(T.obs, f, pos - 1 + hlen + tlen + 1, flen)
END;
INC(flen)
END;
Dict[0] := T.obs;
N := 1;
off := pos - 1 + hlen;
WHILE Files.Pos(R) < pos - 1 + hlen - 5 DO
Files.Read(R, lib);
IF lib = N THEN
Files.ReadString(R, LName);
Dict[N] := Objects.ThisLibrary(LName);
INC(N)
END;
NEW(q); q.lib := Dict[lib]; q.obj := NIL;
IF ~(q.lib IS Fonts.Font) THEN
Files.Set(S, f, off); Files.Read(S, ref); (*q.lib.GetObj(q.lib, ORD(ref), q.obj)*) q.ref := ORD(ref)
ELSE
q.ref := MIN(INTEGER)
END;
Files.Read(R, q.col);
Files.Read(R, q.voff);
Files.ReadLInt(R, q.len);
IF q.len < 0 THEN
LoadAscii (T, f); RETURN
END;
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.handle := H;
T.trailer := Q; T.len := tlen;
T.org := -1; T.pce := T.trailer; (*init cache*)
IF type = NoSpex2 THEN
(* generate multiple private libs with <= 256 objs *)
FOR i := 0 TO 31 DO
Dict[i] := NIL
END;
Files.Set(R, f, pos - 1 + hlen + tlen + flen);
p := T.trailer.next;
WHILE p # T.trailer DO
IF p.lib = T.obs THEN
Files.ReadInt(R, i);
INC(flen, 2);
IF Dict[i DIV 256] = NIL THEN
NEW(Dict[i DIV 256]);
Objects.OpenLibrary(Dict[i DIV 256])
END;
(*T.obs.GetObj(T.obs, i, p.obj);*) p.obj := NIL; p.ref := i;
p.lib := Dict[i DIV 256];
(*Dict[i DIV 256].PutObj(Dict[i DIV 256], i MOD 256, p.obj)*)
END;
p := p.next
END
END;
len := hlen - 1 + tlen + flen
END Load;
PROCEDURE SyncPiece(T: Text; p: Piece);
VAR
R: Files.Rider;
ch: CHAR;
BEGIN
IF (p.ref >= 0) & (p.obj = NIL) & ~(p.lib IS Fonts.Font) THEN
T.obs.GetObj(T.obs, p.ref, p.obj);
Files.Set(R, p.f, p.off); Files.Read(R, ch);
p.lib.PutObj(p.lib, ORD(ch), p.obj)
END
END SyncPiece;
(** Store text T on disk file f at position pos. Writes the first id character too. len is the number of bytes written. *)
PROCEDURE Store* (T: Text; f: Files.File; pos: LONGINT; VAR len: LONGINT);
TYPE
ObjsBlock = POINTER TO ObjsBlockDesc;
ObjsBlockDesc = RECORD
objs: ARRAY 256 OF Objects.Object;
next: ObjsBlock
END;
VAR
p, q: Piece;
R, W: Files.Rider;
hlen, flen, rlen, m: LONGINT;
id, i: INTEGER;
N, n: SHORTINT;
type, ch: CHAR;
obj: Objects.Object;
M: Objects.BindMsg;
Dict: ARRAY 64 OF Objects.Name;
allObjs, curObjs, objs: ObjsBlock;
BEGIN
Files.Set(W, f, pos);
Files.Write(W, TextBlockId);
Files.Write(W, 0X (*type*)); (*place holder*)
Files.WriteLInt(W, 0 (*hlen*)); (*place holder*)
Dict[0] := "";
N := 1;
p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; q := p.next;
IF p.lib IS Fonts.Font THEN
WHILE (q # T.trailer) & (q.lib = p.lib) & (q.col = p.col) & (q.voff = p.voff) DO
rlen := rlen + q.len; q := q.next
END
END;
Dict[N] := p.lib.name;
n := 0;
WHILE Dict[n] # p.lib.name DO INC(n) END;
Files.Write(W, n);
IF n = N THEN Files.WriteString(W, p.lib.name); INC(N) END;
Files.Write(W, p.col);
Files.Write(W, p.voff);
Files.WriteLInt(W, rlen);
p := q
END;
Files.Write(W, 0X); Files.WriteLInt(W, T.len);
NEW(allObjs);
allObjs.next := NIL;
curObjs := allObjs;
hlen := Files.Pos(W) - pos;
id := 0; p := T.trailer.next;
WHILE p # T.trailer DO
Files.Set(R, p.f, p.off); m := p.len;
WHILE m # 0 DO Files.Read(R, ch);
IF p.lib.name[0] = 0X THEN
SyncPiece(T, p);
p.lib.GetObj(p.lib, ORD(ch), obj); p.obj := obj;
curObjs.objs[id MOD 256] := obj;
i := 0; objs := allObjs;
WHILE objs.objs[i MOD 256] # obj DO
INC(i);
IF (i MOD 256) = 0 THEN
objs := objs.next
END
END;
IF i = id THEN INC(id);
IF (id MOD 256) = 0 THEN
NEW(curObjs.next); p.ref := id;
curObjs := curObjs.next;
curObjs.next := NIL
END
END;
ch := CHR(i)
END;
Files.Write(W, ch); DEC(m)
END;
p := p.next
END;
IF id > 0 THEN
IF id > 255 THEN type := NoSpex2
ELSE type := NoSpex
END;
NEW(T.obs); Objects.OpenLibrary(T.obs);
i := 0; objs := allObjs;
REPEAT
T.obs.PutObj(T.obs, i, objs.objs[i MOD 256]);
INC(i);
IF (i MOD 256) = 0 THEN objs := objs.next END
UNTIL i = id;
M.lib := T.obs;
i := 0; objs := allObjs;
REPEAT
objs.objs[i MOD 256].handle(objs.objs[i MOD 256], M);
INC(i);
IF (i MOD 256) = 0 THEN objs := objs.next END
UNTIL i = id;
Objects.StoreLibrary(T.obs, f, pos + hlen + T.len, flen);
IF type = NoSpex2 THEN
(* append a reference block to the text file *)
Files.Set(W, f, pos + hlen + T.len + flen);
p := T.trailer.next;
WHILE p # T.trailer DO
IF p.lib.name[0] = 0X THEN
i := 0; objs := allObjs;
WHILE objs.objs[i MOD 256] # p.obj DO
INC(i);
IF (i MOD 256) = 0 THEN objs := objs.next END
END;
Files.WriteInt(W, i);
INC(flen, 2)
END;
p := p.next
END
END
ELSE type := TextSpex; flen := 0 (*no integrated objects*)
END;
Files.Set(W, f, pos + 1);
Files.Write(W, type); (*fixup*)
Files.WriteLInt(W, hlen); (*fixup*)
len := hlen + T.len + flen
END Store;
PROCEDURE GenNew (T: Text);
VAR Q: Piece;
BEGIN
NEW(Q); Q.f := Wfile; Q.off := 0; Q.len := 1; Q.ref := MIN(INTEGER);
Q.lib := NIL; Q.col := 127; Q.voff := 0;
Q.next := Q; Q.prev := Q;
T.handle := H; T.obs := NIL;
T.trailer := Q; T.len := 0;
T.org := -1; T.pce := T.trailer (*init cache*)
END GenNew;
(** Open text T from file specified by name. A new text is opened when name = "". *)
PROCEDURE Open* (T: Text; CONST name: ARRAY OF CHAR);
VAR f: Files.File; R: Files.Rider; len: LONGINT; ch: CHAR;
BEGIN
obs := NIL;
f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.Read(R, ch);
IF ch = DocBlockId THEN ReadDocHeader(R, ch) END;
IF (ch = TextBlockId) OR (ch = OldTextBlockId) THEN Load(T, f, Files.Pos(R), len)
ELSE LoadAscii(T, f)
END
ELSE GenNew(T)
END
END Open;
(** Text generator procedure. Resulting text is assigned to Objects.NewObj. *)
PROCEDURE New*;
VAR T: Text;
BEGIN NEW(T); T.handle := H; GenNew (T); Objects.NewObj := T
END New;
PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR p: Piece);
VAR n: LONGINT;
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.ref := MIN(INTEGER);
q.lib := p.lib; 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;
(** Insert buffer B in text T position pos. B is emptied. *)
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR pl, pr, p, qb, qe: Piece; org: LONGINT; M: UpdateMsg;
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) & (pl.lib IS Fonts.Font)
& (pl.lib = qb.lib) & (pl.col = qb.col) & (pl.voff = qb.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;
M.text := T; M.F := NIL; M.beg := pos; M.end := pos; M.len := B.len;
B.last := B.header; B.last.next := NIL; B.len := 0;
Display.Broadcast(M); T.stamp := M.stamp
END Insert;
(** Append buffer to the end of text T. B is emptied. *)
PROCEDURE Append* (T: Text; B: Buffer);
BEGIN Insert(T, T.len, B)
END Append;
(** Delete text stretch [beg, end[. *)
PROCEDURE Delete* (T: Text; beg, end: LONGINT);
VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT; M: UpdateMsg;
BEGIN
IF beg < end THEN
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 - end + beg;
M.text := T; M.F := NIL; M.beg := beg; M.end := end; M.len := 0;
Display.Broadcast(M); T.stamp := M.stamp
END
END Delete;
(** Replace [beg, end[ of T with contents of buffer B. B is emptied. *)
PROCEDURE Replace* (T: Text; beg, end: LONGINT; B: Buffer);
VAR M: UpdateMsg; pb, pe, pbr, per, pl, qb, qe: Piece; orgb, orge: LONGINT;
BEGIN
IF beg < end THEN
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;
pl := pbr.prev; qb := B.header.next;
IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len) & (pl.lib IS Fonts.Font)
& (pl.lib = qb.lib) & (pl.col = qb.col) & (pl.voff = qb.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 := per; per.prev := qe
END;
T.len := T.len - end + beg + B.len;
M.text := T; M.F := NIL; M.beg := beg; M.end := end; M.len := B.len;
B.last := B.header; B.last.next := NIL; B.len := 0;
Display.Broadcast(M); T.stamp := M.stamp
END
END Replace;
(** Change character attributes within stretch [beg, end[ of text T. sel selects the attributes to be changed: 0, 1, 2 IN sel = fnt, col, voff selected. *)
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; lib: Objects.Library; col, voff: SHORTINT);
VAR pb, pe, p: Piece; org: LONGINT; M: UpdateMsg; A: Objects.AttrMsg;
BEGIN
IF beg < end THEN
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) & (p.lib IS Fonts.Font) THEN p.lib := lib END;*)
IF (0 IN sel) & (p.lib IS Fonts.Font) THEN
p.lib := lib
ELSIF ~(p.lib IS Fonts.Font) THEN
SyncPiece(T, p);
IF (p.obj # NIL) & (p.obj.handle # NIL) THEN
IF 1 IN sel THEN
A.id := Objects.get; A.name := "Color"; A.class := Objects.Inval; A.res := -1;
p.obj.handle(p.obj, A);
IF A.res = 0 THEN
A.id := Objects.set; A.class := Objects.Int; A.i := LONG(col) MOD 256;
p.obj.handle(p.obj, A)
END
END;
IF (0 IN sel) & (lib # NIL) & (lib IS Fonts.Font) THEN
A.id := Objects.get; A.name := "Font"; A.class := Objects.Inval; A.res := -1;
p.obj.handle(p.obj, A);
IF A.res = 0 THEN
A.id := Objects.set; A.class := Objects.String; COPY(lib(Fonts.Font).name, A.s);
p.obj.handle(p.obj, A)
END
END
END
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;
M.text := T; M.F := NIL; M.beg := beg; M.end := end; M.len := end - beg;
Display.Broadcast(M); T.stamp := M.stamp
END
END ChangeLooks;
(** Open a new text buffer B. *)
PROCEDURE OpenBuf* (B: Buffer);
BEGIN NEW(B.header); (*null piece*) B.header.ref := MIN(INTEGER);
B.last := B.header; B.len := 0
END OpenBuf;
(** Save stretch [beg, end[ of T in buffer B. *)
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR p, q, qb, qe: Piece; org: LONGINT;
BEGIN
IF beg < end THEN
FindPiece(T, beg, org, p); SyncPiece(T, p);
NEW(qb); qb^ := p^; qb.ref := MIN(INTEGER);
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; SyncPiece(T, p);
NEW(q); q^ := p^; q.ref := MIN(INTEGER);
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
END Save;
(** Append copy of source buffer SB to destination buffer DB. *)
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.ref := MIN(INTEGER); q^ := p^; Q.next := q; q.prev := Q; Q := q
END;
DB.last := Q; DB.len := DB.len + SB.len
END Copy;
(** Recall previously deleted text. *)
PROCEDURE Recall* (VAR B: Buffer); (*deleted text*)
BEGIN Copy(DelBuf, B)
END Recall;
(** Default handler for text objects. This handler understands Objects.AttrMsg(for Gen attribute), Objects.CopyMsg, Objects.BindMsg, and Objects.FileMsg only. *)
PROCEDURE Handle* (obj: Objects.Object; VAR M: Objects.ObjMsg);
VAR T: Text; B: Buffer; len: LONGINT; id: INTEGER; ch: CHAR;
BEGIN
WITH obj: Text DO
IF M IS Objects.AttrMsg THEN
WITH M: Objects.AttrMsg DO
IF M.name = "Gen" THEN M.class := Objects.String; M.s := "Texts.New"; M.res := 0 END
END
ELSIF M IS Objects.CopyMsg THEN
WITH M: Objects.CopyMsg DO
NEW(B); OpenBuf(B); Save(obj, 0, obj.len, B);
NEW(T); T.handle := obj.handle; GenNew(T); Insert(T, 0, B); M.obj := T
END
ELSIF M IS Objects.BindMsg THEN
WITH M: Objects.BindMsg DO
IF (obj.lib = NIL) OR (obj.lib.name[0] = 0X) & (obj.lib # M.lib) THEN
M.lib.GenRef(M.lib, id); M.lib.PutObj(M.lib, id, obj)
END
END
ELSIF M IS Objects.FileMsg THEN
WITH M: Objects.FileMsg DO
IF M.id = Objects.load THEN Files.Read(M.R, ch);
IF ch = DocBlockId THEN ReadDocHeader(R, ch) END;
IF (ch = TextBlockId) OR (ch = OldTextBlockId) THEN
Load(obj, Files.Base(M.R), Files.Pos(M.R), len);
Files.Set(M.R, Files.Base(M.R), Files.Pos(M.R) + len)
END
ELSE (*M.id = Objects.store*)
Store(obj, Files.Base(M.R), Files.Pos(M.R), len);
Files.Set(M.R, Files.Base(M.R), Files.Pos(M.R) + len)
END
END
END
END
END Handle;
(** Open Finder at position pos in T. The finder is automatically advanced to the next object in text. *)
PROCEDURE OpenFinder* (VAR F: Finder; T: Text; pos: LONGINT);
VAR p: Piece; org: LONGINT;
BEGIN
FindPiece(T, pos, org, p); F.T := T;
WHILE (p.f # Wfile) & (p.lib IS Fonts.Font) DO
org := org + p.len; p := p.next
END;
F.pos := org; F.ref := p; F.eot := FALSE
END OpenFinder;
(** Advance Finder to next object in text and return current object. *)
PROCEDURE FindObj* (VAR F: Finder; VAR obj: Objects.Object);
VAR p: Piece; org: LONGINT;
BEGIN
obj := F.ref.obj;
IF obj = NIL THEN (* load object *)
SyncPiece(F.T, F.ref); obj := F.ref.obj
END;
IF F.ref.f = Wfile THEN F.eot := TRUE END;
org := F.pos; p := F.ref;
REPEAT org := org + p.len; p := p.next
UNTIL (p.f = Wfile) OR ~(p.lib IS Fonts.Font);
F.pos := org; F.ref := p
END FindObj;
(** Open text reader R and set it up at position pos in text T. *)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR p: Piece; org: LONGINT;
BEGIN
FindPiece(T, pos, org, p); R.T := T; R.lib := NIL;
R.stamp := T.stamp; R.bufpos := 0; R.buflen := 0;
R.ref := p; R.org := org; R.off := pos - org;
R.lib := p.lib; R.col := p.col; R.voff := p.voff;
IF p.ref >= 0 THEN SyncPiece(T, p) END;
Files.Set(R.R, p.f, p.off + R.off); R.eot := p.f = Wfile
END OpenReader;
(** Read next character into ch. R.eot is set when the last character is read. The fields lib, voff and col of R give
information about the last character read. *)
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
VAR ref: Piece;
BEGIN
IF (R.stamp # R.T.stamp) OR (R.bufpos >= R.buflen) THEN
IF R.stamp = R.T.stamp THEN
ref := R.ref; R.bufpos := 0; R.buflen := ref.len-R.off;
IF R.buflen <= 0 THEN
R.org := R.org + ref.len; R.off := 0; ref := ref.next; R.ref := ref;
R.lib := ref.lib; R.col := ref.col; R.voff := ref.voff;
IF ref.ref >= 0 THEN SyncPiece(R.T, ref) END;
Files.Set(R.R, ref.f, ref.off);
R.buflen := ref.len; IF ref.f = Wfile THEN R.eot := TRUE END
END;
IF R.buflen > BufSize THEN R.buflen := BufSize END;
Files.ReadBytes(R.R, R.buf, R.buflen)
ELSE
OpenReader(R, R.T, R.org + R.off);
Read(R, ch); RETURN
END
END;
ch := R.buf[R.bufpos]; INC(R.bufpos); INC(R.off)
END Read;
(** Return reader's position within the text. *)
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(** Open text scanner S and set it up at position pos in text T. *)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.class := Inval; Read(S, S.nextCh)
END OpenScanner;
(* Scanners --------------- NW --------------- *)
(*IEEE floating-point formats (BM 1992.1.1): (-1)^s * 1.m * 2^(e-e0), where
s e e0 m
REAL 1-bit 8-bit biased 127 1+23-bit explicit
LONGREAL 1-bit 11-bit biased 1023 1+52-bit explicit*)
(** Read the next symbol. Whitespace is ignored. CR increments the line counter. *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 256; (* fixed size: maxD <= LEN(S.s)! *)
VAR ch, E: CHAR;
neg, negE, hex, sign: BOOLEAN;
i, j, h, e, k, k1, k2, k3: LONGINT;
y: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF (S.lib = NIL) OR ~(S.lib IS Fonts.Font) THEN EXIT
ELSIF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) & (ch # LF) THEN EXIT
END ;
Read(S, ch)
END;
IF S.lib = NIL THEN
S.class := Inval; S.eot := TRUE; Read(S, ch)
ELSIF ~(S.lib IS Fonts.Font) THEN
S.class := Object; S.lib.GetObj(S.lib, ORD(ch), S.obj); Read(S, ch)
ELSIF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch = ".") OR (ch = "/") (*OR (ch = ":")*) THEN (*name*)
REPEAT
S.s[i] := ch; INC(i); Read(S, ch)
UNTIL ~(nameChars[ORD(ch)]) OR ~(S.lib IS Fonts.Font) OR (i = LEN(S.s)-1);
S.s[i] := 0X;
IF (i = 1) & ((CAP(S.s[0]) < "A") OR (CAP(S.s[0]) > "Z")) THEN
S.c := S.s[0]; S.class := Char
ELSE
S.len := SHORT(SHORT(i)); S.class := Name
END
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (S.lib IS Fonts.Font) & (i # LEN(S.s)-1) DO
S.s[i] := ch; INC(i); Read(S, ch)
END;
WHILE (ch # 22X) & (ch >= " ") & (S.lib IS Fonts.Font) DO Read(S, ch) END;
S.s[i] := 0X; S.len := SHORT(SHORT(i)); Read(S, ch); S.class := String
ELSE
IF ch = "-" THEN sign := TRUE; neg := TRUE; Read(S, ch)
ELSIF ch = "+" THEN sign := TRUE; neg := FALSE; Read(S, ch)
ELSE sign := FALSE; neg := FALSE
END;
IF ("0" <= ch) & (ch <= "9") & (S.lib IS Fonts.Font) THEN (*number*)
hex := FALSE; j := 0;
LOOP
d[i] := ch; INC(i); Read(S, ch);
IF (ch < "0") OR ~(S.lib IS Fonts.Font) OR (i >= maxD) 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") & (S.lib IS Fonts.Font) THEN (*hex number*)
Read(S, ch); S.class := Int;
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 = ".") & (S.lib IS Fonts.Font) THEN (*read real*)
Read(S, ch); h := i;
WHILE ("0" <= ch) & (ch <= "9") & (S.lib IS Fonts.Font) & (i < maxD) DO
d[i] := ch; INC(i); Read(S, ch)
END;
(*-------- begin floating-point handling BM 1993.3.10 -----------------------------------*)
WHILE i MOD 8 # 0 DO d[i] := "0"; INC(i) END;
j := 0; k := 0; k1 := 0; k2 := 0; k3 := 0; (* store digits 0..7, 8..15, 16..23, 24..31 in k, k1, k2, k3 *)
WHILE j < 8 DO k := k*10 + ORD(d[j]) - ORD("0"); INC(j) END;
IF 8 < i THEN
WHILE j < 16 DO k1 := k1*10 + ORD(d[j]) - ORD("0"); INC(j) END
END;
IF 16 < i THEN
WHILE j < 24 DO k2 := k2*10 + ORD(d[j]) - ORD("0"); INC(j) END
END;
IF 24 < i THEN
WHILE j < 32 DO k3 := k3*10 + ORD(d[j]) - ORD("0"); INC(j) END
END;
e := 0; E := ch;
IF ((E = "D") OR (E = "E")) & (S.lib IS Fonts.Font) THEN Read(S, ch);
IF (ch = "-") & (S.lib IS Fonts.Font) THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF (ch = "+") & (S.lib IS Fonts.Font) THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") & (S.lib IS Fonts.Font) DO
e := e*10 + ORD(ch) - ORD("0");
Read(S, ch)
END;
IF negE THEN e := - e END
END;
y := k3*Reals.Ten(-32) + k2*Reals.Ten(-24); y := y + k1*Reals.Ten(-16);
IF ABS(e+h) < 308 THEN y := (y + k*Reals.Ten(-8)) / Reals.Ten(-e-h)
ELSE y := (y + k*Reals.Ten(-8)) * Reals.Ten(h);
IF (e <= 308-32) OR (e <= 308) & (y < MAX(LONGREAL) / Reals.Ten(e)) THEN y := y * Reals.Ten(e)
ELSE y := MAX(LONGREAL)
END
END;
IF E = "D" THEN
IF y = MAX(LONGREAL) THEN S.class := Inval (* NaN *)
ELSE S.class := LongReal;
IF neg THEN S.y := - y ELSE S.y := y END;
IF Reals.ExpoL(S.y) = 0 THEN S.y := 0 END
END
ELSIF MAX(REAL) < y THEN S.class:= Inval (* NaN *)
ELSE S.class := Real;
IF neg THEN S.x := SHORT(- y) ELSE S.x := SHORT(y) END;
IF Reals.Expo(S.x) = 0 THEN S.x := 0 END
END;
(*-------- end floating-point handling BM 1993.3.10 -----------------------------------*)
IF hex THEN S.class := Inval END
ELSE (*decimal integer*)
S.class := Int; k := 0;
WHILE (j # i) & ((k < MAX(LONGINT) DIV 10) OR
(k = MAX(LONGINT) DIV 10) & ((ORD(d[j]) - 30H) <= MAX(LONGINT) MOD 10)) DO (*JG*)
k := k*10 + (ORD(d[j]) - 30H); INC(j)
END;
IF j # i THEN S.class := Inval
ELSE
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := Inval ELSE S.class := Int END
END
END
ELSE S.class := Char;
IF sign THEN IF neg THEN S.c := "-" ELSE S.c := "+" END
ELSE S.c := ch; Read(S, ch)
END
END
END;
S.nextCh := ch
END Scan;
(** Open a new writer W. *)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN
NEW(W.buf); OpenBuf(W.buf); W.lib := Fonts.Default; W.col := 15; W.voff := 0;
Files.Set(W.R, Files.New(""), 0)
END OpenWriter;
(** Set writer W to font fnt. *)
PROCEDURE SetFont* (VAR W: Writer; fnt: Objects.Library);
BEGIN W.lib := fnt
END SetFont;
(** Set writer W to color col. *)
PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT);
BEGIN W.col := col
END SetColor;
(** Set writer W to vertical offset voff. Vertical offset controls the writing of super- and sub-scripts. *)
PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT);
BEGIN W.voff := voff
END SetOffset;
(** Write character ch to writer W's buffer. *)
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR p, q: Piece;
BEGIN p := W.buf.last;
IF ~(W.lib IS Fonts.Font) OR (W.lib # p.lib) OR (W.col # p.col) OR (W.voff # p.voff) OR (Files.Base(W.R) # p.f) THEN
NEW(q); q.ref := MIN(INTEGER);
IF ~(W.lib IS Fonts.Font) THEN W.lib.GetObj(W.lib, ORD(ch), q.obj) END;
q.f := Files.Base(W.R); q.off := Files.Pos(W.R); q.len := 0;
q.lib := W.lib; q.col := W.col; q.voff:= W.voff;
q.next := NIL; p.next := q; q.prev := p; p := q;
W.buf.last := p
END;
Files.Write(W.R, ch);
INC(p.len); INC(W.buf.len)
END Write;
(** Write an end-of-line character to W's buffer. *)
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
(** Write string s to W's buffer. *)
PROCEDURE WriteString* (VAR W: Writer; CONST s: ARRAY OF CHAR);
VAR i: LONGINT;
BEGIN i := 0;
WHILE s[i] # 0X DO Write(W, s[i]); INC(i) END
END WriteString;
(** Write integer x to W's buffer. Spaces are padded to the left until the number field is at least n characters long. *)
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i, x0: LONGINT;
a: ARRAY 10 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;
(** Write a hexadecimal representation of x to W's buffer. *)
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i, 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;
(** Write the hexadecimal representation of x to W's buffer. *)
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
BEGIN (* BM 1991.12.25 *) WriteHex(W, Reals.Int(x))
END WriteRealHex;
(** Write the hexadecimal representation of x to W's buffer. *)
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR h, l: LONGINT; (* BM 1991.12.25 *)
BEGIN Reals.IntL(x, h, l); WriteHex(W, h); WriteHex(W, l)
END WriteLongRealHex;
(** Write real x to W's buffer using n character positions. *)
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: LONGINT);
(* BM 1993.4.22. Do not simplify rounding! *)
VAR e, h, i: LONGINT; y: LONGREAL; z: REAL; d: ARRAY 8 OF CHAR;
BEGIN
e:= Reals.Expo(x);
IF e = 255 THEN
WHILE n > 8 DO Write(W, " "); DEC(n) END;
h := Reals.NaNCode(x);
IF h # 0 THEN WriteString(W, " NaN")
ELSIF x < 0 THEN WriteString(W, " -INF")
ELSE WriteString(W, " INF")
END
ELSE
IF n <= 8 THEN n := 1 ELSE DEC(n, 7) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 7; (* 0 <= n <= 7 fraction digits *)
IF (e # 0) & (x < 0) THEN Write(W, "-"); x := - x ELSE Write(W, " ") END;
IF e = 0 THEN h := 0 (* no denormals *)
ELSE e := (e - 127) * 301 DIV 1000; (* ln(2)/ln(10) = 0.301029996 *)
IF e < 38 THEN z := SHORT(Reals.Ten(e+1));
IF x >= z THEN y := LONG(x)/LONG(z); INC(e) ELSE y := x * Reals.Ten(-e) END
ELSE y := x * Reals.Ten(-38) END;
IF y >= 10 THEN y := y * Reals.Ten(-1) + 0.5D0 / Reals.Ten(n); INC(e)
ELSE y := y + 0.5D0 / Reals.Ten(n);
IF y >= 10 THEN y := y * Reals.Ten(-1); INC(e) END
END;
y := y * Reals.Ten(7); h := ENTIER(y)
END;
i := 7;
WHILE i >= 0 DO d[i] := CHR(h MOD 10 + ORD("0")); h := h DIV 10; DEC(i) END;
Write(W, d[0]); Write(W, "."); i := 1; WHILE i <= n DO Write(W, d[i]); INC(i) END;
IF e < 0 THEN WriteString(W, "E-"); e := - e ELSE WriteString(W, "E+") END;
Write(W, CHR(e DIV 10 + ORD("0")));
Write(W, CHR(e MOD 10 + ORD("0")))
END
END WriteReal;
(** Write real x in a fixed point notation. n is the overall minimal length for the output field,
f the number of fraction digits following the decimal point, E the fixed exponent (printed only
when E # 0). *)
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, f, E: LONGINT);
(* BM 1993.4.22. Do not simplify rounding ! / JG formatting adjusted *)
VAR e, h, i: LONGINT; r, y: LONGREAL; z: REAL; s: CHAR; d: ARRAY 8 OF CHAR;
BEGIN
e := Reals.Expo(x);
IF (e = 255) OR (ABS(E) > 38) THEN
WHILE n > 8 DO Write(W, " "); DEC(n) END;
h := Reals.NaNCode(x);
IF h # 0 THEN WriteString(W, " NaN")
ELSIF x < 0 THEN WriteString(W, " -INF")
ELSE WriteString(W, " INF")
END
ELSE
IF E = 0 THEN DEC(n, 2) ELSE DEC(n, 6) END;
IF f < 0 THEN f := 0 END;
IF n < f + 2 THEN n := f + 2 END;
DEC(n, f);
IF (e # 0) & (x < 0) THEN s:= "-"; x:= - x ELSE s:= " " END;
IF e = 0 THEN h := 0; DEC(e, E-1) (* no denormals *)
ELSE
e := (e - 127) * 301 DIV 1000; (* ln(2)/ln(10) = 0.301029996 *)
IF e < 38 THEN z := SHORT(Reals.Ten(e+1));
IF x >= z THEN y := LONG(x)/LONG(z); INC(e) ELSE y := x * Reals.Ten(-e) END
ELSE y := x * Reals.Ten(-38) END;
DEC(e, E-1); i := -(e+f);
IF i <= 0 THEN r := 5 * Reals.Ten(i) ELSE r := 0 END;
IF y >= 10 THEN y := y * Reals.Ten(-1) + r; INC(e)
ELSE y := y + r;
IF y >= 10 THEN y := y * Reals.Ten(-1); INC(e) END
END;
y := y * Reals.Ten(7); h := ENTIER(y)
END;
i := 7;
WHILE i >= 0 DO d[i] := CHR(h MOD 10 + ORD("0")); h := h DIV 10; DEC(i) END;
IF n <= e THEN n := e + 1 END;
IF e > 0 THEN WHILE n > e DO Write(W, " "); DEC(n) END;
Write(W, s); e := 0;
WHILE n > 0 DO DEC(n);
IF e < 8 THEN Write(W, d[e]); INC(e) ELSE Write(W, "0") END
END;
Write(W, ".")
ELSE
WHILE n > 1 DO Write(W, " "); DEC(n) END;
Write(W, s); Write(W, "0"); Write(W, ".");
WHILE (0 < f) & (e < 0) DO Write(W, "0"); DEC(f); INC(e) END
END;
WHILE f > 0 DO DEC(f);
IF e < 8 THEN Write(W, d[e]); INC(e) ELSE Write(W, "0") END
END;
IF E # 0 THEN
IF E < 0 THEN WriteString(W, "E-"); E := - E
ELSE WriteString(W, "E+")
END;
Write(W, CHR(E DIV 10 + ORD("0"))); Write(W, CHR(E MOD 10 + ORD("0")))
END
END
END WriteRealFix;
(** Write LONGREAL x to W's buffer using n character positions. *)
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: LONGINT);
(* BM 1993.4.22. Do not simplify rounding! *)
VAR e, h, l, i: LONGINT; z: LONGREAL; d: ARRAY 16 OF CHAR;
BEGIN
e:= Reals.ExpoL(x);
IF e = 2047 THEN
WHILE n > 9 DO Write(W, " "); DEC(n) END;
Reals.NaNCodeL(x, h, l);
IF (h # 0) OR (l # 0) THEN WriteString(W, " NaN")
ELSIF x < 0 THEN WriteString(W, " -INF")
ELSE WriteString(W, " INF")
END
ELSE
IF n <= 9 THEN n:= 1 ELSE DEC(n, 8) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 15; (* 0 <= n <= 15 fraction digits *)
IF (e # 0) & (x < 0) THEN Write(W, "-"); x:= - x ELSE Write(W, " ") END;
IF e = 0 THEN h:= 0; l:= 0 (* no denormals *)
ELSE e:= (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
z:= Reals.Ten(e+1);
IF x >= z THEN x:= x/z; INC(e) ELSE x:= x * Reals.Ten(-e) END;
IF x >= 10 THEN x:= x * Reals.Ten(-1) + 0.5D0 / Reals.Ten(n); INC(e)
ELSE x:= x + 0.5D0 / Reals.Ten(n);
IF x >= 10 THEN x:= x * Reals.Ten(-1); INC(e) END
END;
x:= x * Reals.Ten(7); h:= ENTIER(x); x:= (x-h) * Reals.Ten(8); l:= ENTIER(x)
END;
i:= 15; WHILE i > 7 DO d[i]:= CHR(l MOD 10 + ORD("0")); l:= l DIV 10; DEC(i) END;
WHILE i >= 0 DO d[i]:= CHR(h MOD 10 + ORD("0")); h:= h DIV 10; DEC(i) END;
Write(W, d[0]); Write(W, "."); i:= 1; WHILE i <= n DO Write(W, d[i]); INC(i) END;
IF e < 0 THEN WriteString(W, "D-"); e:= - e ELSE WriteString(W, "D+") END;
Write(W, CHR(e DIV 100 + ORD("0"))); e:= e MOD 100;
Write(W, CHR(e DIV 10 + ORD("0"))); Write(W, CHR(e MOD 10 + ORD("0")))
END
END WriteLongReal;
(** Write LONGREAL x in a fixed point notation. n is the overall minimal length for the output field, f the number of fraction digits following the decimal point, D the fixed exponent (printed only when D # 0). *)
PROCEDURE WriteLongRealFix* (VAR W: Writer; x: LONGREAL; n, f, D: LONGINT);
(* BM 1993.4.22. Do not simplify rounding! / JG formatting adjusted *)
VAR e, h, l, i: LONGINT; r, z: LONGREAL; d: ARRAY 16 OF CHAR; s: CHAR;
BEGIN
e := Reals.ExpoL(x);
IF (e = 2047) OR (ABS(D) > 308) THEN
WHILE n > 9 DO Write(W, " "); DEC(n) END;
Reals.NaNCodeL(x, h, l);
IF (h # 0) OR (l # 0) THEN WriteString(W, " NaN")
ELSIF x < 0 THEN WriteString(W, " -INF")
ELSE WriteString(W, " INF")
END
ELSE
IF D = 0 THEN DEC(n, 2) ELSE DEC(n, 7) END;
IF n < 2 THEN n := 2 END;
IF f < 0 THEN f := 0 END;
IF n < f + 2 THEN n := f + 2 END;
DEC(n, f);
IF (e # 0) & (x < 0) THEN s := "-"; x := - x ELSE s := " " END;
IF e = 0 THEN h := 0; l := 0; DEC(e, D-1) (* no denormals *)
ELSE
e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
z := Reals.Ten(e+1);
IF x >= z THEN x := x/z; INC(e) ELSE x:= x * Reals.Ten(-e) END;
DEC(e, D-1); i := -(e+f);
IF i <= 0 THEN r := 5 * Reals.Ten(i) ELSE r := 0 END;
IF x >= 10 THEN x := x * Reals.Ten(-1) + r; INC(e)
ELSE x := x + r;
IF x >= 10 THEN x := x * Reals.Ten(-1); INC(e) END
END;
x := x * Reals.Ten(7); h:= ENTIER(x); x := (x-h) * Reals.Ten(8); l := ENTIER(x)
END;
i := 15;
WHILE i > 7 DO d[i] := CHR(l MOD 10 + ORD("0")); l := l DIV 10; DEC(i) END;
WHILE i >= 0 DO d[i] := CHR(h MOD 10 + ORD("0")); h := h DIV 10; DEC(i) END;
IF n <= e THEN n := e + 1 END;
IF e > 0 THEN WHILE n > e DO Write(W, " "); DEC(n) END;
Write(W, s); e:= 0;
WHILE n > 0 DO DEC(n);
IF e < 16 THEN Write(W, d[e]); INC(e) ELSE Write(W, "0") END
END;
Write(W, ".")
ELSE
WHILE n > 1 DO Write(W, " "); DEC(n) END;
Write(W, s); Write(W, "0"); Write(W, ".");
WHILE (0 < f) & (e < 0) DO Write(W, "0"); DEC(f); INC(e) END
END;
WHILE f > 0 DO DEC(f);
IF e < 16 THEN Write(W, d[e]); INC(e) ELSE Write(W, "0") END
END;
IF D # 0 THEN
IF D < 0 THEN WriteString(W, "D-"); D := - D
ELSE WriteString(W, "D+")
END;
Write(W, CHR(D DIV 100 + ORD("0"))); D := D MOD 100;
Write(W, CHR(D DIV 10 + ORD("0"))); Write(W, CHR(D MOD 10 + ORD("0")))
END
END
END WriteLongRealFix;
(** Write the time and date to W's buffer. *)
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);
Write(W, "."); WriteInt(W, 1900 + d DIV 512, 1);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
(** Write a SET value to writer W. *)
PROCEDURE WriteSet*(VAR W: Writer; s: SET);
VAR
i, last: LONGINT;
dots: BOOLEAN;
BEGIN
Write(W, "{"); last := MIN(LONGINT);
FOR i := MIN(SET) TO MAX(SET) DO
IF i IN s THEN
IF last = (i-1) THEN
IF dots THEN
WriteString(W, " .. "); dots := FALSE
END;
IF (i = MAX(SET)) OR ~((i+1) IN s) THEN
WriteInt(W, i, 0)
END
ELSE
IF last >= MIN(SET) THEN
WriteString(W, ", ")
END;
WriteInt(W, i, 0); dots := TRUE
END;
last := i
END
END;
Write(W, "}")
END WriteSet;
(** Write obj to writer W. *)
PROCEDURE WriteObj*(VAR W: Writer; obj: Objects.Object);
VAR lib: Objects.Library;
BEGIN
IF (obj.lib = NIL) OR (obj.ref < 0) OR (obj.lib.name = "") THEN (* free or private *)
IF obs = NIL THEN
NEW(obs); Objects.OpenLibrary(obs)
END;
obs.GenRef(obs, obj.ref);
IF obj.ref >= 256 THEN
NEW(obs); Objects.OpenLibrary(obs);
obs.GenRef(obs, obj.ref)
END;
obs.PutObj(obs, obj.ref, obj)
END;
ASSERT(obj.ref < 256);
lib := W.lib;
SetFont(W, obj.lib);
Write(W, CHR(obj.ref));
SetFont(W, lib)
END WriteObj;
PROCEDURE InitScan;
VAR i: LONGINT;
BEGIN
FOR i := 0 TO 255 DO nameChars[i] := FALSE END;
FOR i := 80H TO 96H DO nameChars[i] := TRUE END; (* german characters *)
FOR i := ORD("0") TO ORD("9") DO nameChars[i] := TRUE END;
FOR i := ORD("A") TO ORD("Z") DO nameChars[i] := TRUE END;
FOR i := ORD("a") TO ORD("z") DO nameChars[i] := TRUE END;
nameChars[ORD("@")] := TRUE; (* mail, compiler *)
nameChars[ORD(".")] := TRUE; (* mail, filenames, compiler *)
nameChars[ORD("/")] := TRUE; (* filenames *)
nameChars[ORD(":")] := TRUE; (* filenames (Mac) *)
nameChars[ORD("_")] := TRUE
END InitScan;
BEGIN
TextBlockId := 0F0X; DocBlockId := 0F7X; NoSpex := 0X; TextSpex := 1X; NoSpex2 := 2X;
H := Handle; Wfile := Files.New(""); Files.Set(R, Wfile, 0); Files.Write(R, 0X);
NEW(DelBuf); OpenBuf(DelBuf); InitScan(); obs := NIL
END Texts.
(** Remarks:
1. Text streams consists of sequence of characters (type Fonts.Char) and and
non-character objects (in different colors, fonts, and vertical offsets). The only
way to distinguish between a character and an object in the text stream is by
fetching the character/object from its library and then making a type test.
The library of a character/object is given by the lib field of the reader while
advancing through a text stream. The reference number of a character/object
is the ordinal number of the character read (i.e. ORD(ch)). As character objects
are bound to character fonts (Fonts.Font), a quick type test of the Reader lib
field against Fonts.Font also settles the question. Non-character objects of a
text are typically bound to the obs library field of the text descriptor.
2. The non-character objects of a text stream must have reference numbers
in the range 0 <= ref < 256, and must be bound to a library (not necessarily
obs of the text descriptor). Writing non-character objects involves binding it
to a library (say T.obs), changing the font of the Writer, and the writing the
reference number of the non-character object into the writer's buffer.
Afterwards the writer font is reset to its old value. More that 256 non-character
objects can be written into the text by allocating a new library when the old
library is full, and attaching it to the obs field of the text descriptor. The obs field
just acts as a placeholder for libraries and is not used by the texts directly.
3. There are two mechanisms to read from a text and one to write to a text.
The Readers allow characterwise reading from a certain text position onwards.
The Scanners allow reading of formatted tokens like names, strings, numbers and
characters. Writers are used to write characters into temporary holding areas
called buffers. Buffers contains large sequences of objects (both character and
non-character) and allow low-level temporary manipulation. The difference
between texts and buffers involve the display update operations. Each text can
possibly be represented on the display by some kind of text editor or viewer.
When a module manipulates a text, a message called the UpdateMsg (type
Texts.UpdateMsg) is broadcast to all viewers or text editors representing the text.
They then update their representation accordingly. To prevent broadcasts being
sent for potentially each character being written into a text, the text manipulation
is first done in a buffer. Operations on buffers do not result in update messages
being broadcasted. Only when a buffer is applied to a text (inserted or appended),
the texts broadcasts an update message. By convention, once a buffer is applied
to a text, its contents is emptied.
4. The scanner classes indicate what token was scanned. The scanner understands
the following token types:
Name Longest sequence starting with "A".."Z", "a".."z", ".", "/", and containing
"A".."Z", "a".."z", "0".."9", "@", ".", "/", ":", "_", 80X..96X
String Any character sequence surrounded by double quotes, i.e. "string".
The quotes are not returned in the s field of the scanner descriptor.
Int Any valid integer number.
Real Any valid REAL number, including exponent E.
LongReal Any valid LONGREAL number, including exponent D.
Char A character (single) not classified as one of the above.
5. The end of line character is carriage return (CR or 0DX), tabulators are 9X.
Unprintable characters are show on the display as smallish square boxes.
6. Vertical offsets are typically measured in screen pixels (positive or negative
to the text base line).
7. The Finder allow quick searching for non-character objects in a text.
8. The meaning of the UpdateMsg fields are defined as in the following table
listed according to the procedures that broadcast the message. Note that a text
stretch identified by (beg, end) does not include the character at position end
in the text. Below, M is of type Texts.UpdateMsg and B stands for a buffer.
Delete(beg, end) M.beg = beg
M.end = end
M.len = 0
Replace(beg, end, B) M.beg = beg
M.end = end
M.len = B.len
ChangeLooks(beg, end) M.beg = beg
M.end = end
M.len = end - beg
Insert(pos, buf) M.beg = pos
M.end = pos
M.len = B.len
The general scheme is that the stretch between M.beg and M.end was "deleted",
and a new stretch of length M.len was inserted at M.beg. The message indicates
a change AFTER it has already been made by the texts module.
9. There is an asymmetry in writing and reading texts to a file. Each text "block"
in a file is identified by a first character. Reading a text block requires that the
starting position does not include this character, while writing a text block writes
the id character automatically.
10. Opening of non-text files is allowed with Texts.Open; they are simply converted
to ASCII streams. Storing such an opened text will convert it into an Oberon text.
Note that the EditTools package allows the manipulation of ASCII texts both in
MSDOS and UNIX format.
*)