home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / languages / obrn-a_1.5_lib.lha / oberon-a / source2.lha / Source / ProjectOberon / Texts.mod < prev   
Encoding:
Text File  |  1995-01-26  |  24.7 KB  |  910 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Texts.mod $
  4.   Description: A port of the Project Oberon Texts module
  5.  
  6.    Created by: J. Gutknecht
  7.     Ported by: fjc (Frank Copeland)
  8.     $Revision: 1.6 $
  9.       $Author: fjc $
  10.         $Date: 1995/01/26 00:48:34 $
  11.  
  12.   Copyright © 1990-1993, ETH Zuerich
  13.   Copyright © 1994, Frank Copeland.
  14.   This file is part of the Oberon-A Library.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17.   Log entries are at the end of the file.
  18.  
  19. ***************************************************************************)
  20.  
  21. <* STANDARD- *> <* MAIN- *>
  22.  
  23. MODULE Texts;
  24.  
  25. IMPORT Kernel, Files, Fonts, Reals;
  26.  
  27. CONST
  28.  
  29.   (* symbol classes *)
  30.  
  31.   Inval *    = 0; (* invalid symbol *)
  32.   Name *     = 1; (* name s (length len) *)
  33.   String *   = 2; (* literal string s (length len) *)
  34.   Int *      = 3; (* integer i (decimal or hexadecimal) *)
  35.   Real *     = 4; (* real number x *)
  36.   LongReal * = 5; (* long real number y *)
  37.   Char *     = 6; (* special character c *)
  38.  
  39.   TAB = 9X; CR = 0DX; maxD = 9;
  40.   LF = 0AX; (* Amiga end-of-line character *)
  41.  
  42.   (* TextBlock = TextBlock off run {run} 0 len {AsciiCode}.
  43.      run = fnt [name] col voff len. *)
  44.  
  45.   TextBlockId = 1FFH;
  46.  
  47.   replace * = 0; insert * = 1; delete * = 2; (* op-codes *)
  48.  
  49. TYPE
  50.  
  51.   Piece = POINTER TO PieceDesc;
  52.   PieceDesc = RECORD
  53.     f     : Files.File;
  54.     off   : LONGINT;
  55.     len   : LONGINT;
  56.     fnt   : Fonts.Font;
  57.     col   : SHORTINT;
  58.     voff  : SHORTINT;
  59.     prev,
  60.     next  : Piece
  61.   END; (* PieceDesc *)
  62.  
  63.   Text * = POINTER TO TextDesc;
  64.  
  65.   Notifier * = PROCEDURE (T : Text; op : INTEGER; beg, end : LONGINT);
  66.  
  67.   TextDesc * = RECORD
  68.     len *    : LONGINT;
  69.     notify * : Notifier;
  70.     trailer  : Piece;
  71.     org      : LONGINT; (* cache *)
  72.     pce      : Piece;
  73.     f        : Files.File (* Holds handle for file opened by Open(). *)
  74.   END; (* TextDesc *)
  75.  
  76.   Reader * = RECORD (Files.Rider)
  77.     eot *  : BOOLEAN;
  78.     fnt *  : Fonts.Font;
  79.     col *  : SHORTINT;
  80.     voff * : SHORTINT;
  81.     ref    : Piece;
  82.     org    : LONGINT;
  83.     off    : LONGINT
  84.   END; (* Reader *)
  85.  
  86.   Scanner * = RECORD (Reader)
  87.     nextCh * : CHAR;
  88.     line *   : INTEGER;
  89.     class *  : INTEGER;
  90.     i *      : LONGINT;
  91.     x *      : REAL;
  92.     y *      : LONGREAL;
  93.     c *      : CHAR;
  94.     len *    : SHORTINT;
  95.     s *      : ARRAY 32 OF CHAR
  96.   END; (* Scanner *)
  97.  
  98.   Buffer * = POINTER TO BufDesc;
  99.   BufDesc * = RECORD
  100.     len *   : LONGINT;
  101.     header,
  102.     last    : Piece
  103.   END; (* BufDesc *)
  104.  
  105.   Writer * = RECORD (Files.Rider)
  106.     buf *  : Buffer;
  107.     fnt *  : Fonts.Font;
  108.     col *  : SHORTINT;
  109.     voff * : SHORTINT
  110.   END; (* Writer *)
  111.  
  112. VAR
  113.   W : Writer; WFile : Files.File; DelBuf : Buffer;
  114.  
  115. (*------------------------------------*)
  116. PROCEDURE ReadName ( VAR R : Files.Rider; VAR name : ARRAY OF CHAR );
  117.  
  118.   VAR i : INTEGER; ch : CHAR;
  119.  
  120. BEGIN (* ReadName *)
  121.   i := 0; Files.Read (R, ch); IF ch = LF THEN ch := CR END;
  122.   WHILE ch # 0X DO
  123.     name [i] := ch; INC (i); Files.Read (R, ch);
  124.     IF ch = LF THEN ch := CR END
  125.   END; (* WHILE *)
  126.   name [i] := 0X
  127. END ReadName;
  128.  
  129. (*------------------------------------*)
  130. PROCEDURE WriteName ( VAR W : Files.Rider; VAR name : ARRAY OF CHAR );
  131.  
  132.   VAR i : INTEGER; ch : CHAR;
  133.  
  134. BEGIN (* WriteName *)
  135.   i := 0; ch := name [i];
  136.   WHILE ch # 0X DO
  137.     Files.Write (W, ch); INC (i); ch := name [i]
  138.   END; (* WHILE *)
  139.   Files.Write (W, 0X)
  140. END WriteName;
  141.  
  142. (*------------------------------------*)
  143. PROCEDURE Load *
  144.   ( T       : Text;
  145.     f       : Files.File;
  146.     pos     : LONGINT;
  147.     VAR len : LONGINT);
  148.  
  149.   VAR
  150.     R       : Files.Rider;
  151.     Q, q, p : Piece;
  152.     off     : LONGINT;
  153.     N, fnt  : SHORTINT;
  154.     FName   : ARRAY 32 OF CHAR;
  155.     Dict    : ARRAY 32 OF Fonts.Font;
  156.  
  157. BEGIN (* Load *)
  158.   N := 1;
  159.   NEW (Q);
  160.   Q.f := WFile; Q.off := 0; Q.len := 1; Q.fnt := NIL; Q.col := 0;
  161.   Q.voff := 0; p := Q;
  162.   Files.Set (R, f, pos); Files.ReadBytes (R, off, SIZE (LONGINT));
  163.   LOOP
  164.     Files.Read (R, fnt);
  165.     IF fnt = 0 THEN EXIT END;
  166.     IF fnt = N THEN
  167.       ReadName (R, FName);
  168.       Dict [N] := Fonts.This (FName);
  169.       INC (N)
  170.     END; (* IF *)
  171.     NEW (q);
  172.     q.fnt := Dict [fnt];
  173.     Files.Read (R, q.col);
  174.     Files.Read (R, q.voff);
  175.     Files.ReadBytes (R, q.len, SIZE (LONGINT));
  176.     q.f := f; q.off := off;
  177.     off := off + q.len;
  178.     p.next := q; q.prev := p; p := q
  179.   END; (* LOOP *)
  180.   p.next := Q; Q.prev := p;
  181.   T.trailer := Q; Files.ReadBytes (R, T.len, SIZE (LONGINT));
  182.   T.org := -1; T.pce := T.trailer; (* init cache *)
  183.   len := off - pos
  184. END Load;
  185.  
  186. (*------------------------------------*)
  187. PROCEDURE Open * ( T : Text; name : ARRAY OF CHAR );
  188.  
  189.   VAR
  190.     f    : Files.File;
  191.     R    : Files.Rider;
  192.     Q, q : Piece;
  193.     id   : INTEGER;
  194.     len  : LONGINT;
  195.  
  196. <*$CopyArrays-*>
  197. BEGIN (* Open *)
  198.   T.f := NIL; f := Files.Old (name);
  199.   IF f # NIL THEN
  200.     Files.Set (R, f, 0); Files.ReadBytes (R, id, SIZE (INTEGER));
  201.     IF id = TextBlockId THEN
  202.       Load (T, f, 2, len)
  203.     ELSE (* Ascii file *)
  204.       len := Files.Length (f);
  205.       NEW (Q);
  206.       Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile;
  207.       Q.off := 0; Q.len := 1;
  208.       NEW (q);
  209.       q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f;
  210.       q.off := 0; q.len := len;
  211.       Q.next := q; q.prev := Q; q.next := Q; Q.prev := q;
  212.       T.trailer := Q; T.len := len;
  213.       T.org := -1; T.pce := T.trailer (* init cache *)
  214.     END
  215.   ELSE (* create new text *)
  216.     NEW (Q);
  217.     Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile;
  218.     Q.off := 0; Q.len := 1; Q.next := Q; Q.prev := Q;
  219.     T.trailer := Q; T.len := 0;
  220.     T.org := -1; T.pce := T.trailer (* init cache *)
  221.   END;
  222.   T.f := f;
  223. END Open;
  224.  
  225. (*------------------------------------*)
  226. PROCEDURE Close * ( T : Text );
  227.  
  228. BEGIN (* Close *)
  229.   IF T.f # NIL THEN Files.Close (T.f) END
  230. END Close;
  231.  
  232. (*------------------------------------*)
  233. PROCEDURE OpenBuf * (B : Buffer);
  234.  
  235. BEGIN (* OpenBuf *)
  236.   NEW (B.header); (* null piece *)
  237.   B.last := B.header; B.len := 0
  238. END OpenBuf;
  239.  
  240. (*------------------------------------*)
  241. PROCEDURE FindPiece
  242.   ( T       : Text;
  243.     pos     : LONGINT;
  244.     VAR org : LONGINT;
  245.     VAR p   : Piece );
  246.  
  247.   VAR n : INTEGER;
  248.  
  249. BEGIN (* FindPiece *)
  250.   IF pos < T.org THEN T.org := -1; T.pce := T.trailer END;
  251.   org := T.org; p := T.pce; (* from cache *)
  252.   n := 0;
  253.   WHILE pos >= org + p.len DO
  254.     org := org + p.len; p := p.next; INC (n)
  255.   END; (* WHILE *)
  256.   IF n > 50 THEN T.org := org; T.pce := p END;
  257. END FindPiece;
  258.  
  259. (*------------------------------------*)
  260. PROCEDURE SplitPiece ( p : Piece; off : LONGINT; VAR pr : Piece );
  261.  
  262.   VAR q : Piece;
  263.  
  264. BEGIN (* SplitPiece *)
  265.   IF off > 0 THEN
  266.     NEW (q);
  267.     q.fnt := p.fnt; q.col := p.col; q.voff := p.voff; q.len := p.len - off;
  268.     q.f := p.f; q.off := p.off + off;
  269.     p.len := off;
  270.     q.next := p.next; p.next := q;
  271.     q.prev := p; q.next.prev := q;
  272.     pr := q
  273.   ELSE
  274.     pr := p
  275.   END; (* ELSE *)
  276. END SplitPiece;
  277.  
  278. (*------------------------------------*)
  279. PROCEDURE OpenReader * ( VAR R : Reader; T : Text; pos : LONGINT );
  280.  
  281.   VAR p : Piece; org : LONGINT;
  282.  
  283. BEGIN (* OpenReader *)
  284.   FindPiece (T, pos, org, p);
  285.   R.ref := p; R.org := org; R.off := pos - org;
  286.   Files.Set (R, R.ref.f, R.ref.off + R.off); R.eot := FALSE;
  287. END OpenReader;
  288.  
  289. (*------------------------------------*)
  290. PROCEDURE Read * ( VAR R : Reader; VAR ch : CHAR );
  291.  
  292. BEGIN (* Read *)
  293.   Files.Read (R, ch); IF ch = LF THEN ch := CR END;
  294.   R.fnt := R.ref.fnt; R.col := R.ref.col;
  295.   R.voff := R.ref.voff; INC (R.off);
  296.   IF R.off = R.ref.len THEN
  297.     IF R.ref.f = WFile THEN R.eot := TRUE END;
  298.     R.org := R.org + R.off; R.off := 0;
  299.     R.ref := R.ref.next;
  300.     R.org := R.org + R.off; R.off := 0;
  301.     Files.Set (R, R.ref.f, R.ref.off)
  302.   END; (* IF *)
  303. END Read;
  304.  
  305. (*------------------------------------*)
  306. PROCEDURE Pos * ( VAR R : Reader ) : LONGINT;
  307.  
  308. BEGIN (* Pos *)
  309.   RETURN R.org + R.off
  310. END Pos;
  311.  
  312. (*------------------------------------*)
  313. PROCEDURE Store *
  314.   ( T       : Text;
  315.     f       : Files.File;
  316.     pos     : LONGINT;
  317.     VAR len : LONGINT );
  318.  
  319.   VAR
  320.     p, q : Piece;
  321.     R : Reader; W : Files.Rider;
  322.     off, rlen : LONGINT; id : INTEGER;
  323.     N, n : SHORTINT; ch : CHAR;
  324.     Dict : ARRAY 32 OF Fonts.Name;
  325.  
  326. BEGIN (* Store *)
  327.   Files.Set (W, f, pos);
  328.   id := TextBlockId; Files.WriteBytes (W, id, SIZE (INTEGER));
  329.   Files.WriteBytes (W, off, SIZE (LONGINT)); (* place holder *)
  330.   N := 1;
  331.   p := T.trailer.next;
  332.   WHILE p # T.trailer DO
  333.     rlen := p.len; q := p.next;
  334.     WHILE
  335.       (q # T.trailer)
  336.       & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff)
  337.     DO
  338.       rlen := rlen + q.len; q := q.next;
  339.     END; (* WHILE *)
  340.     Dict [N] := p.fnt.name; n := 1;
  341.     WHILE Dict [n] # p.fnt.name DO INC (n) END;
  342.     Files.Write (W, n);
  343.     IF n = N THEN WriteName (W, p.fnt.name); INC (N) END;
  344.     Files.Write (W, p.col); Files.Write (W, p.voff);
  345.     Files.WriteBytes (W, rlen, SIZE (LONGINT));
  346.     p := q
  347.   END; (* WHILE *)
  348.   Files.Write (W, 0); Files.WriteBytes (W, T.len, SIZE (LONGINT));
  349.   off := Files.Pos (W);
  350.   OpenReader (R, T, 0); Read (R, ch);
  351.   WHILE ~R.eot DO Files.Write (W, ch); Read (R, ch) END;
  352.   Files.Set (W, f, pos + SIZE (INTEGER));
  353.   Files.WriteBytes (W, off, SIZE (LONGINT)); (* fixup *)
  354.   len := off + T.len - pos
  355. END Store;
  356.  
  357. (*------------------------------------*)
  358. PROCEDURE Save * ( T : Text; beg, end : LONGINT; B : Buffer );
  359.  
  360.   VAR
  361.     p, q, qb, qe : Piece;
  362.     org : LONGINT;
  363.  
  364. BEGIN (* Save *)
  365.   IF end > T.len THEN end := T.len END;
  366.   FindPiece (T, beg, org, p);
  367.   NEW (qb);
  368.   qb^ := p^; qb.len := qb.len - (beg - org);
  369.   qb.off := qb.off + (beg - org);
  370.   qe := qb;
  371.   WHILE end > org + p.len DO
  372.     org := org + p.len; p := p.next;
  373.     NEW (q);
  374.     q^ := p^; qe.next := q; q.prev := qe; qe := q
  375.   END; (* WHILE *)
  376.   qe.next := NIL; qe.len := qe.len - (org + p.len - end);
  377.   B.last.next := qb; qb.prev := B.last; B.last := qe;
  378.   B.len := B.len + (end - beg)
  379. END Save;
  380.  
  381. (*------------------------------------*)
  382. PROCEDURE Copy * ( SB, DB : Buffer );
  383.  
  384.   VAR Q, q, p : Piece;
  385.  
  386. BEGIN (* Copy *)
  387.   p := SB.header; Q := DB.last;
  388.   WHILE p # SB.last DO
  389.     p := p.next;
  390.     NEW (q);
  391.     q^ := p^; Q.next := q; q.prev := Q; Q := q
  392.   END; (* WHILE *)
  393.   DB.last := Q; DB.len := DB.len + SB.len
  394. END Copy;
  395.  
  396. (*------------------------------------*)
  397. PROCEDURE ChangeLooks *
  398.   ( T         : Text;
  399.     beg, end  : LONGINT;
  400.     sel       : SET;
  401.     fnt       : Fonts.Font;
  402.     col, voff : SHORTINT );
  403.  
  404.   VAR
  405.     pb, pe, p : Piece;
  406.     org : LONGINT;
  407.  
  408. BEGIN (* ChangeLooks *)
  409.   IF end > T.len THEN end := T.len END;
  410.   FindPiece (T, beg, org, p); SplitPiece (p, beg - org, pb);
  411.   FindPiece (T, end, org, p); SplitPiece (p, end - org, pe);
  412.   p := pb;
  413.   REPEAT
  414.     IF 0 IN sel THEN p.fnt := fnt END;
  415.     IF 1 IN sel THEN p.col := col END;
  416.     IF 2 IN sel THEN p.voff := voff END;
  417.   UNTIL p = pe;
  418.   T.notify (T, replace, beg, end)
  419. END ChangeLooks;
  420.  
  421. (*------------------------------------*)
  422. PROCEDURE Insert * ( T : Text; pos : LONGINT; B : Buffer );
  423.  
  424.   VAR
  425.     pl, pr, p, qb, qe : Piece;
  426.     org, end : LONGINT;
  427.  
  428. BEGIN (* Insert *)
  429.   FindPiece (T, pos, org, p); SplitPiece (p, pos - org, pr);
  430.   IF T.org >= org THEN (* adjust cache *)
  431.     T.org := org - p.prev.len; T.pce := p.prev
  432.   END; (* IF *)
  433.   pl := pr.prev;
  434.   qb := B.header.next;
  435.   IF
  436.     (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
  437.     & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff)
  438.   THEN
  439.     pl.len := pl.len + qb.len; qb := qb.next
  440.   END; (* IF *)
  441.   IF qb # NIL THEN
  442.     qe := B.last;
  443.     qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
  444.   END; (* IF *)
  445.   T.len := T.len + B.len; end := pos + B.len;
  446.   B.last := B.header; B.last.next := NIL; B.len := 0;
  447.   T.notify (T, insert, pos, end)
  448. END Insert;
  449.  
  450. (*------------------------------------*)
  451. PROCEDURE Append * ( T : Text; B : Buffer );
  452.  
  453. BEGIN (* Append *)
  454.   Insert (T, T.len, B)
  455. END Append;
  456.  
  457. (*------------------------------------*)
  458. PROCEDURE Delete * ( T : Text; beg, end : LONGINT );
  459.  
  460.   VAR
  461.     pb, pe, pbr, per : Piece;
  462.     orgb, orge : LONGINT;
  463.  
  464. BEGIN (* Delete *)
  465.   IF end > T.len THEN end := T.len END;
  466.   FindPiece (T, beg, orgb, pb); SplitPiece (pb, beg - orgb, pbr);
  467.   FindPiece (T, end, orge, pe); SplitPiece (pe, end - orge, per);
  468.   IF T.org >= orgb THEN (* adjust cache *)
  469.     T.org := orgb - pb.prev.len; T.pce := pb.prev
  470.   END; (* IF *)
  471.   DelBuf.header.next := pbr; DelBuf.last := per.prev;
  472.   DelBuf.last.next := NIL; DelBuf.len := end - beg;
  473.   per.prev := pbr.prev;
  474.   pbr.prev.next := per;
  475.   T.len := T.len - DelBuf.len;
  476.   T.notify (T, delete, beg, end)
  477. END Delete;
  478.  
  479. (*------------------------------------*)
  480. PROCEDURE Recall ( VAR B : Buffer ); (* deleted text *)
  481.  
  482. BEGIN (* Recall *)
  483.   B := DelBuf; NEW (DelBuf); OpenBuf (DelBuf)
  484. END Recall;
  485.  
  486. (*------------------------------------*)
  487. PROCEDURE OpenScanner * ( VAR S : Scanner; T : Text; pos : LONGINT );
  488.  
  489. BEGIN (* OpenScanner *)
  490.   OpenReader (S, T, pos); S.line := 0; Read (S, S.nextCh)
  491. END OpenScanner;
  492.  
  493. (*------------------------------------*)
  494. PROCEDURE Scan * ( VAR S : Scanner );
  495.  
  496.   CONST
  497.     maxD = 32;
  498.     (* Limits for exponents *)
  499.     MaxNegD = 20; (* LONGREAL : Motorola FFP reals *)
  500.     MaxPosD = 18;
  501.     MaxNegE = 20; (* REAL : Motorola FFP reals *)
  502.     MaxPosE = 18;
  503.  
  504.   VAR
  505.     ch, term : CHAR;
  506.     neg, negE, hex : BOOLEAN;
  507.     i, j, h : SHORTINT;
  508.     e : INTEGER; k : LONGINT;
  509.     x, f : REAL; y, g : LONGREAL;
  510.     d : ARRAY maxD OF CHAR;
  511.  
  512.   (*------------------------------------*)
  513.   PROCEDURE ReadScaleFactor ();
  514.  
  515.   BEGIN (* ReadScaleFactor *)
  516.     Read (S, ch);
  517.     IF ch = "-" THEN
  518.       negE := TRUE; Read (S, ch)
  519.     ELSE
  520.       negE := FALSE; IF ch = "+" THEN Read (S, ch) END;
  521.     END;
  522.     WHILE (ch >= "0") & (ch <= "9") DO
  523.       e := e * 10 + ORD (ch) - 30H; Read (S, ch)
  524.     END; (* WHILE *)
  525.   END ReadScaleFactor;
  526.  
  527. BEGIN (* Scan *)
  528.   ch := S.nextCh; i := 0;
  529.   LOOP
  530.     IF (ch = CR) OR (ch = LF) THEN INC (S.line)
  531.     ELSIF (ch # " ") & (ch # TAB) THEN EXIT
  532.     END;
  533.     Read (S, ch)
  534.   END; (* LOOP *)
  535.   IF (CAP (ch) >= "A") & (CAP (ch) <= "Z") THEN (* name *)
  536.     REPEAT
  537.       S.s [i] := ch; INC (i); Read (S, ch)
  538.     UNTIL
  539.       (CAP (ch) > "Z")
  540.       OR (CAP (ch) < "A") & (ch > "9")
  541.       OR (ch < "0") & (ch # ".")
  542.       OR (i = 31);
  543.     S.s [i] := 0X; S.len := i; S.class := Name
  544.   ELSIF ch = 22X THEN (* literal string *)
  545.     Read (S, ch);
  546.     WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO
  547.       S.s [i] := ch; INC (i); Read (S, ch)
  548.     END; (* WHILE *)
  549.     S.s [i] := 0X; S.len := i + 1; S.class := String
  550.   ELSE
  551.     IF ch = "-" THEN neg := TRUE; Read (S, ch) ELSE neg := FALSE END;
  552.     IF (ch >= "0") & (ch <= "9") THEN (* number *)
  553.       hex := FALSE; j := 0;
  554.       LOOP
  555.         d [i] := ch; INC (i); Read (S, ch);
  556.         IF ch < "0" THEN EXIT END;
  557.         IF "9" < ch THEN
  558.           IF ("A" <= ch) & (ch <= "F") THEN
  559.             hex := TRUE; ch := CHR (ORD (ch) - 7)
  560.           ELSIF ("a" <= ch) & (ch <= "f") THEN
  561.             hex := TRUE; ch := CHR (ORD (ch) - 27H)
  562.           ELSE
  563.             EXIT
  564.           END; (* ELSE *)
  565.         END; (* IF *)
  566.       END; (* LOOP *)
  567.       IF ch = "H" THEN (* hex number *)
  568.         Read (S, ch); S.class := Int;
  569.         IF i - j > 8 THEN j := i - 8 END;
  570.         k := ORD (d [j]) - 30H; INC (j);
  571.         IF (i - j = 7) & (k >= 8) THEN DEC (k, 16) END;
  572.         WHILE j < i DO k := k * 10H + (ORD (d [j]) - 30H); INC (j) END;
  573.         IF neg THEN S.i := -k ELSE S.i := k END;
  574.       ELSIF ch = "." THEN (* read real *)
  575.         Read (S, ch); h := i;
  576.         WHILE ("0" <= ch) & (ch <= "9") DO
  577.           d [i] := ch; INC (i); Read (S, ch)
  578.         END;
  579.         IF ch = "D" THEN
  580.           e := 0; y := 0.0; g := 1.0;
  581.           REPEAT y := y * 10.0 + (ORD (d [j]) - 30H); INC (j) UNTIL j = h;
  582.           WHILE j < i DO
  583.             g := g / 10.0; y := (ORD (d [j]) - 30H) * g + y; INC (j)
  584.           END;
  585.           ReadScaleFactor;
  586.           IF negE THEN
  587.             IF e <= MaxNegD THEN y := y / Reals.TenL (e) ELSE y := 0.0 END
  588.           ELSIF e > 0 THEN
  589.             IF e <= MaxPosD THEN y := y * Reals.TenL (e) ELSE HALT (40) END
  590.           END; (* IF *)
  591.           IF neg THEN y := -y END;
  592.           S.class := LongReal; S.y := y
  593.         ELSE
  594.           e := 0; x := 0.0; f := 1.0;
  595.           REPEAT x := x * 10.0 + (ORD (d [j]) - 30H); INC (j) UNTIL j = h;
  596.           WHILE j < i DO
  597.             f := f / 10.0; x := (ORD (d [j]) - 30H) * f + x; INC (j)
  598.           END;
  599.           IF ch = "E" THEN ReadScaleFactor END;
  600.           IF negE THEN
  601.             IF e <= MaxNegE THEN x := x / Reals.Ten (e) ELSE x := 0.0 END
  602.           ELSIF e > 0 THEN
  603.             IF e <= MaxPosE THEN x := x * Reals.Ten (e) ELSE HALT (40) END
  604.           END; (* IF *)
  605.           IF neg THEN x := -x END;
  606.           S.class := Real; S.x := x
  607.         END; (* ELSE *)
  608.         IF hex THEN S.class := Inval END
  609.       ELSE (* decimal integer *)
  610.         S.class := Int; k := 0;
  611.         REPEAT k := k * 10 + (ORD (d [j]) - 30H); INC (j) UNTIL j = i;
  612.         IF neg THEN S.i := -k ELSE S.i := k END;
  613.         IF hex THEN S.class := Inval ELSE S.class := Int END
  614.       END; (* ELSE *)
  615.     ELSE
  616.       S.class := Char;
  617.       IF neg THEN S.c := "-" ELSE S.c := ch; Read (S, ch) END
  618.     END; (* ELSE *)
  619.   END; (* ELSE *)
  620.   S.nextCh := ch
  621. END Scan;
  622.  
  623. (*------------------------------------*)
  624. PROCEDURE OpenWriter * ( VAR W : Writer );
  625.  
  626. BEGIN (* OpenWriter *)
  627.   NEW (W.buf); OpenBuf (W.buf); W.fnt := Fonts.Default; W.col := 1;
  628.   W.voff := 0; Files.Set (W, Files.New (""), 0)
  629. END OpenWriter;
  630.  
  631. (*------------------------------------*)
  632. PROCEDURE CloseWriter * ( VAR W : Writer );
  633.  
  634. BEGIN (* CloseWriter *)
  635.   Files.Purge (Files.Base (W))
  636. END CloseWriter;
  637.  
  638. (*------------------------------------*)
  639. PROCEDURE SetFont * ( VAR W : Writer; fnt : Fonts.Font );
  640.  
  641. BEGIN (* SetFont *)
  642.   W.fnt := fnt
  643. END SetFont;
  644.  
  645. (*------------------------------------*)
  646. PROCEDURE SetColor * ( VAR W : Writer; col : SHORTINT );
  647.  
  648. BEGIN (* SetColor *)
  649.   W.col := col
  650. END SetColor;
  651.  
  652. (*------------------------------------*)
  653. PROCEDURE SetOffset * ( VAR W : Writer; voff : SHORTINT );
  654.  
  655. BEGIN (* SetOffset *)
  656.   W.voff := voff
  657. END SetOffset;
  658.  
  659. (*------------------------------------*)
  660. PROCEDURE Write * ( VAR W : Writer; ch : CHAR );
  661.  
  662.   VAR p : Piece;
  663.  
  664. BEGIN (* Write *)
  665.   IF
  666.     (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col)
  667.     OR (W.buf.last.voff # W.voff)
  668.   THEN
  669.     NEW (p);
  670.     p.f := Files.Base (W); p.off := Files.Pos (W); p.len := 0;
  671.     p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
  672.     p.next := NIL; W.buf.last.next := p;
  673.     p.prev := W.buf.last; W.buf.last := p
  674.   END; (* IF *)
  675.   Files.Write (W, ch);
  676.   INC (W.buf.last.len); INC (W.buf.len)
  677. END Write;
  678.  
  679. (*------------------------------------*)
  680. PROCEDURE WriteLn * ( VAR W : Writer );
  681.  
  682. BEGIN (* WriteLn *)
  683.   Write (W, CR)
  684. END WriteLn;
  685.  
  686. (*------------------------------------*)
  687. PROCEDURE WriteString * ( VAR W : Writer; s : ARRAY OF CHAR );
  688.  
  689.   VAR i : LONGINT;
  690.  
  691. <*$CopyArrays-*>
  692. BEGIN (* WriteString *)
  693.   i := 0; WHILE s [i] # 0X DO Write (W, s [i]); INC (i) END
  694. END WriteString;
  695.  
  696. (*------------------------------------*)
  697. PROCEDURE WriteInt * ( VAR W : Writer; x, n : LONGINT );
  698.  
  699.   VAR i : INTEGER; x0 : LONGINT; a : ARRAY 11 OF CHAR;
  700.  
  701. BEGIN (* WriteInt *)
  702.   i := 0;
  703.   IF x < 0 THEN
  704.     IF x = MIN (LONGINT) THEN
  705.       WriteString (W, " -2147483648"); RETURN
  706.     ELSE
  707.       DEC (n); x0 := -x
  708.     END; (* ELSE *)
  709.   ELSE
  710.     x0 := x
  711.   END; (* ELSE *)
  712.   REPEAT
  713.     a [i] := CHR (x0 MOD 10 + 30H); x0 := x0 DIV 10; INC (i)
  714.   UNTIL x0 = 0;
  715.   WHILE n > i DO Write (W, " "); DEC (n) END;
  716.   IF x < 0 THEN Write (W, "-") END;
  717.   REPEAT DEC (i); Write (W, a [i]) UNTIL i = 0;
  718. END WriteInt;
  719.  
  720. (*------------------------------------*)
  721. PROCEDURE WriteHex * ( VAR W : Writer; x : LONGINT );
  722.  
  723.   VAR i : INTEGER; y : LONGINT; a : ARRAY 10 OF CHAR;
  724.  
  725. BEGIN (* WriteHex *)
  726.   i := 0; Write (W, " ");
  727.   REPEAT
  728.     y := x MOD 10H;
  729.     IF y < 10 THEN a [i] := CHR (y + 30H) ELSE a [i] := CHR (y + 37H) END;
  730.     x := x DIV 10H; INC (i)
  731.   UNTIL i = 8;
  732.   REPEAT DEC (i); Write (W, a [i]) UNTIL i = 0
  733. END WriteHex;
  734.  
  735. (*------------------------------------*)
  736. PROCEDURE WriteReal * ( VAR W : Writer; x : REAL; n : INTEGER );
  737.  
  738.   VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;
  739.  
  740. BEGIN (* WriteReal *)
  741.   (*
  742.    * This implementation uses Motorola FFP format reals instead of IEEE
  743.    * single-precision reals.  The Project Oberon code has been modified to
  744.    * remove the special-case handling of unnormal and NaN values and assume
  745.    * 7-bit exponents instead of 8-bit.
  746.    *)
  747.   e := Reals.Expo (x);
  748.   IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  749.   REPEAT Write (W, " "); DEC (n) UNTIL n <= 8;
  750.   (* there are 2 < n <= 8 digits to be written *)
  751.   IF x < 0.0 THEN Write (W, "-"); x := -x ELSE Write (W, " ") END;
  752.   e := (e - 64) * 77 DIV 256;
  753.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  754.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  755.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  756.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  757.   Reals.Convert (x, n, d);
  758.   DEC (n); Write (W, d [n]); Write (W, ".");
  759.   REPEAT DEC (n); Write (W, d [n]) UNTIL n = 0;
  760.   Write (W, "E");
  761.   IF e < 0 THEN Write (W, "-"); e := -e ELSE Write (W, "+") END;
  762.   Write (W, CHR (e DIV 10 + 30H)); Write (W, CHR (e MOD 10 + 30H))
  763. END WriteReal;
  764.  
  765. (*------------------------------------*)
  766. PROCEDURE WriteRealFix * ( VAR W : Writer; x : REAL; n, k : INTEGER );
  767.  
  768.   VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;
  769.  
  770.   (*------------------------------------*)
  771.   PROCEDURE seq ( ch : CHAR; n : LONGINT );
  772.  
  773.   BEGIN (* seq *)
  774.     WHILE n > 0 DO Write (W, ch); DEC (n) END
  775.   END seq;
  776.  
  777.   (*------------------------------------*)
  778.   PROCEDURE dig (n : INTEGER);
  779.  
  780.   BEGIN (* dig *)
  781.     WHILE n > 0 DO
  782.       DEC (i); Write (W, d [i]); DEC (n)
  783.     END;
  784.   END dig;
  785.  
  786. BEGIN (* WriteRealFix *)
  787.   (*
  788.    * This implementation uses Motorola FFP format reals instead of IEEE
  789.    * single-precision reals.  The Project Oberon code has been modified to
  790.    * remove the special-case handling of unnormal and NaN values and assume
  791.    * 7-bit exponents instead of 8-bit.
  792.    *)
  793.   IF k < 0 THEN k := 0 END;
  794.   e := (Reals.Expo (x) - 64) * 77 DIV 256;
  795.   IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  796.   IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  797.   ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  798.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  799.   (* 1 <= x < 10 *)
  800.   IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  801.   ELSIF k + e < 0 THEN k := -e; x := 0.0
  802.   END;
  803.   x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  804.   IF x >= 10.0 * x0 THEN INC (e) END;
  805.   (* e = no. of digits before decimal point *)
  806.   INC (e); i := k + e; Reals.Convert (x, i, d);
  807.   IF e > 0 THEN
  808.     seq (" ", n - e - k - 2); Write (W, sign); dig (e); Write (W, ".");
  809.     dig (k)
  810.   ELSE
  811.     seq (" ", n - k - 3); Write (W, sign); Write (W, "0"); Write (W, ".");
  812.     seq ("0", -e); dig (k + e)
  813.   END; (* ELSE *)
  814. END WriteRealFix;
  815.  
  816. (*------------------------------------*)
  817. PROCEDURE WriteRealHex * ( VAR W : Writer; x : REAL );
  818.  
  819.   VAR i : INTEGER; d : ARRAY 8 OF CHAR;
  820.  
  821. BEGIN (* WriteRealHex *)
  822.   Reals.ConvertH (x, d); i := 0;
  823.   REPEAT Write (W, d [i]); INC (i) UNTIL i = 8
  824. END WriteRealHex;
  825.  
  826. (*------------------------------------*)
  827. PROCEDURE WriteLongReal * ( VAR W : Writer; x : LONGREAL; n : INTEGER );
  828.  
  829. BEGIN (* WriteLongReal *)
  830.   (*
  831.    * In this implementation, LONGREAL and REAL types are the same, so this
  832.    * procedure is implemented as a call to WriteReal ().
  833.    *)
  834.   WriteReal (W, SHORT (x), n)
  835. END WriteLongReal;
  836.  
  837. (*------------------------------------*)
  838. PROCEDURE WriteLongRealHex * ( VAR W : Writer; x : LONGREAL );
  839.  
  840. BEGIN (* WriteLongRealHex *)
  841.   (*
  842.    * In this implementation, LONGREAL and REAL types are the same, so this
  843.    * procedure is implemented as a call to WriteRealHex ().
  844.    *)
  845.   WriteRealHex (W, SHORT (x))
  846. END WriteLongRealHex;
  847.  
  848. (*------------------------------------*)
  849. PROCEDURE WriteDate * ( VAR W : Writer; t, d : LONGINT );
  850.  
  851.   (*------------------------------------*)
  852.   PROCEDURE WritePair (ch : CHAR; x : LONGINT);
  853.  
  854.   BEGIN (* WritePair *)
  855.     Write (W, ch);
  856.     Write (W, CHR (x DIV 10 + 30H)); Write (W, CHR (x MOD 10 + 30H))
  857.   END WritePair;
  858.  
  859. BEGIN (* WriteDate *)
  860.   WritePair (" ", d MOD 32); WritePair (".", d DIV 32 MOD 16);
  861.   WritePair (".", d DIV 512 MOD 128);
  862.   WritePair (" ", t DIV 4096 MOD 32); WritePair (":", t DIV 64 MOD 64);
  863.   WritePair (":", t MOD 64)
  864. END WriteDate;
  865.  
  866. (*------------------------------------*)
  867. PROCEDURE * Cleanup (VAR rc : LONGINT);
  868.  
  869. BEGIN (* Cleanup *)
  870.   CloseWriter (W);
  871. END Cleanup;
  872.  
  873. BEGIN (* Texts *)
  874.   NEW (DelBuf); OpenBuf (DelBuf);
  875.   OpenWriter (W); Write (W, 0X);
  876.   WFile := Files.Base (W);
  877.   Kernel.SetCleanup (Cleanup)
  878. END Texts.
  879.  
  880. (***************************************************************************
  881.  
  882.   $Log: Texts.mod $
  883.   Revision 1.6  1995/01/26  00:48:34  fjc
  884.   - Release 1.5
  885.  
  886.   Revision 1.5  1994/11/11  17:00:38  fjc
  887.   - Uses new external code interface.
  888.  
  889.   Revision 1.5  1994/11/11  17:00:38  fjc
  890.   - Uses new external code interface.
  891.  
  892.   Revision 1.4  1994/09/18  21:25:47  fjc
  893.   - Converted switches to pragmas/options
  894.  
  895.   Revision 1.4  1994/09/18  21:25:47  fjc
  896.   - Converted switches to pragmas/options
  897.  
  898.   Revision 1.3  1994/08/08  16:42:00  fjc
  899.   Release 1.4
  900.  
  901.   Revision 1.2  1994/05/12  20:45:18  fjc
  902.   - Prepared for release
  903.  
  904. # Revision 1.1  1994/01/15  21:39:12  fjc
  905. # Start of revision control
  906. #
  907. ***************************************************************************)
  908.  
  909.  
  910.