home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / oberon / potsrc / lib / mod / texts < prev   
Encoding:
Text File  |  1995-01-22  |  13.7 KB  |  425 lines
  1. MODULE Texts;  (** CAS 30-Sep-91 / interface based on Texts by JG / NW 6.12.91**) 
  2.  (* Simplified subset DT 04-Feb-94 *)
  3.   IMPORT Files, Reals;
  4.  
  5.   CONST
  6.     TAB = 9X; NL = 0AX; maxD = 9;
  7.     BufLen = 512;
  8.    (*Scanner.class*)
  9.     Inval* = 0; Name* = 1; String* = 2; Int* = 3; 
  10.     Real* = 4; LongReal* = 5; Char* = 6;
  11.  
  12.   TYPE
  13.     Text* = Files.File;
  14.     
  15.     Buffer* = POINTER TO BufDesc;
  16.  
  17.     BufDesc = RECORD
  18.       next: Buffer;
  19.       len: LONGINT;
  20.       data: ARRAY BufLen OF CHAR
  21.     END;
  22.  
  23.     Reader* = RECORD (Files.Rider)
  24.       org: LONGINT;
  25.       eot*: BOOLEAN
  26.     END;
  27.  
  28.     Scanner* = RECORD (Reader)
  29.       nextCh*: CHAR;
  30.       line*, class*: INTEGER;
  31.       i*: LONGINT;
  32.       x*: REAL;
  33.       y*: LONGREAL;
  34.       c*: CHAR;
  35.       len*: SHORTINT;
  36.       s*: ARRAY 32 OF CHAR
  37.     END;
  38.  
  39.     Writer* = RECORD 
  40.       buf*: Buffer
  41.     END;
  42.  
  43.   PROCEDURE RdString (VAR r: Files.Rider; VAR s: ARRAY OF CHAR);
  44.     VAR i: INTEGER; ch: CHAR;
  45.   BEGIN i := 0;
  46.     REPEAT Files.Read(r, ch); s[i] := ch; INC(i) UNTIL (ch = 0X) OR (i = LEN(s));
  47.     WHILE ~r.eof & (ch # 0X) DO Files.Read(r, ch) END;  (*synch if string too long*)
  48.     s[i] := 0X
  49.   END RdString;
  50.  
  51.   PROCEDURE RdInt (VAR r: Files.Rider; VAR n: INTEGER);
  52.     VAR c0: CHAR; s1: SHORTINT;
  53.   BEGIN Files.Read(r, c0); Files.Read(r, s1);
  54.     n := LONG(s1) * 100H + ORD(c0)
  55.   END RdInt;
  56.  
  57.   PROCEDURE RdLong (VAR r: Files.Rider; VAR n: LONGINT);
  58.     VAR c0, c1, c2: CHAR; s3: SHORTINT;
  59.   BEGIN Files.Read(r, c0); Files.Read(r, c1); Files.Read(r, c2); Files.Read(r, s3);
  60.     n := ( (LONG(s3) * 100H + LONG(ORD(c2))) * 100H + ORD(c1) ) * 100H + ORD(c0)
  61.   END RdLong;
  62.  
  63.  
  64.   PROCEDURE WrtString (VAR r: Files.Rider; VAR s: ARRAY OF CHAR);
  65.     VAR i: INTEGER;
  66.   BEGIN i := 0;
  67.     REPEAT INC(i) UNTIL s[i] = 0X;
  68.     Files.WriteBytes(r, s, i + 1)
  69.   END WrtString;
  70.  
  71.   PROCEDURE WrtInt (VAR r: Files.Rider; n: INTEGER);
  72.   BEGIN Files.Write(r, CHR(n MOD 100H)); Files.Write(r, SHORT(n DIV 100H))
  73.   END WrtInt;
  74.  
  75.   PROCEDURE WrtLong (VAR r: Files.Rider; n: LONGINT);
  76.   BEGIN Files.Write(r, CHR(n MOD 100H)); Files.Write(r, CHR(n DIV 100H MOD 100H));
  77.     Files.Write(r, CHR(n DIV 10000H MOD 100H)); Files.Write(r, SHORT(SHORT((n DIV 1000000H))) )
  78.   END WrtLong;
  79.  
  80.  (* buffers *)
  81.  
  82.   PROCEDURE OpenBuf* (VAR B: Buffer);
  83.   BEGIN NEW(B); B.next := NIL; B.len := 0
  84.   END OpenBuf;
  85.  
  86.   PROCEDURE Append* (T: Text; VAR B: Buffer);
  87.     VAR R: Files.Rider;
  88.     
  89.     PROCEDURE Invert;
  90.       VAR b1, b2: Buffer;
  91.     BEGIN b1 := NIL;
  92.       REPEAT b2 := b1; b1 := B; B := B.next; b1.next := b2 UNTIL B = NIL;
  93.       B := b1
  94.     END Invert;  
  95.   
  96.   BEGIN Files.Set(R, T, Files.Length(T)); Invert;
  97.     LOOP IF B.len = 0 THEN EXIT END;
  98.       Files.WriteBytes(R, B.data, B.len);
  99.       IF B.next = NIL THEN B.len := 0; EXIT END;
  100.       B := B.next
  101.     END;
  102.     Files.Set(R, T, Files.Pos(R))
  103.   END Append;  
  104.  
  105.  (** Readers **)
  106.  
  107.   PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
  108.   BEGIN Files.Set(R, T, pos); R.eot := FALSE; R.org := pos
  109.   END OpenReader;
  110.  
  111.   PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
  112.   BEGIN Files.Read(R, ch); R.eot := R.eof OR (ch = 0X)
  113.   END Read;
  114.  
  115.   PROCEDURE Pos* (VAR R: Reader): LONGINT;
  116.   BEGIN RETURN Files.Pos(R) - R.org
  117.   END Pos;
  118.  
  119.  (* Scanners NW-DT *)
  120.  
  121.   PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
  122.   BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
  123.   END OpenScanner;
  124.  
  125.   (*IEEE floating point formats:
  126.     x = 2^(e-127) * 1.m    bit 0: sign, bits 1- 8: e, bits  9-31: m
  127.     x = 2^(e-1023) * 1.m   bit 0: sign, bits 1-11: e, bits 12-63: m *)
  128.  
  129.   PROCEDURE Scan* (VAR S: Scanner);
  130.     CONST maxD = 32;
  131.     VAR ch, term: CHAR;
  132.       neg, negE, hex: BOOLEAN;
  133.       i, j, h: SHORTINT;
  134.       e: INTEGER; k: LONGINT;
  135.       x, f: REAL; y, g: LONGREAL;
  136.       d: ARRAY maxD OF CHAR;
  137.  
  138.     PROCEDURE ReadScaleFactor;
  139.     BEGIN Read(S, ch);
  140.       IF ch = "-" THEN negE := TRUE; Read(S, ch)
  141.       ELSE negE := FALSE;
  142.         IF ch = "+" THEN Read(S, ch) END
  143.       END;
  144.       WHILE ("0" <= ch) & (ch <= "9") DO
  145.         e := e*10 + ORD(ch) - 30H; Read(S, ch)
  146.       END
  147.     END ReadScaleFactor;
  148.  
  149.   BEGIN ch := S.nextCh; i := 0;
  150.     LOOP
  151.       IF ch = NL THEN INC(S.line)
  152.       ELSIF (ch # " ") & (ch # TAB) THEN EXIT
  153.       END ;
  154.       Read(S, ch)
  155.     END;
  156.     IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") THEN (*name*)
  157.       REPEAT S.s[i] := ch; INC(i); Read(S, ch)
  158.       UNTIL (CAP(ch) > "Z")
  159.         OR ("A" > CAP(ch)) & (ch > "9")
  160.         OR ("0" > ch) & (ch # ".")
  161.         OR (i = 31);
  162.       S.s[i] := 0X; S.len := i; S.class := 1
  163.     ELSIF ch = 22X THEN (*literal string*)
  164.       Read(S, ch);
  165.       WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO
  166.         S.s[i] := ch; INC(i); Read(S, ch)
  167.       END;
  168.       S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
  169.     ELSE
  170.       IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
  171.       IF ("0" <= ch) & (ch <= "9") THEN (*number*)
  172.         hex := FALSE; j := 0;
  173.         LOOP d[i] := ch; INC(i); Read(S, ch);
  174.           IF ch < "0" THEN EXIT END;
  175.           IF "9" < ch THEN
  176.             IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
  177.             ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
  178.             ELSE EXIT
  179.             END
  180.           END
  181.         END;
  182.         IF ch = "H" THEN (*hex number*)
  183.           Read(S, ch); S.class := 3;
  184.           IF i-j > 8 THEN j := i-8 END ;
  185.           k := ORD(d[j]) - 30H; INC(j);
  186.           IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ;
  187.           WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ;
  188.           IF neg THEN S.i := -k ELSE S.i := k END 
  189.         ELSIF ch = "." THEN (*read real*)
  190.           Read(S, ch); h := i;
  191.           WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ;
  192.           IF ch = "D" THEN
  193.             e := 0; y := 0; g := 1;
  194.             REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
  195.             WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
  196.             ReadScaleFactor;
  197.             IF negE THEN
  198.               IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END
  199.             ELSIF e > 0 THEN
  200.               IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END 
  201.             END ;
  202.             IF neg THEN y := -y END ;
  203.             S.class := 5; S.y := y
  204.           ELSE e := 0; x := 0; f := 1;
  205.             REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
  206.             WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
  207.             IF ch = "E" THEN ReadScaleFactor END ;
  208.             IF negE THEN
  209.               IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
  210.             ELSIF e > 0 THEN
  211.               IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
  212.             END ;
  213.             IF neg THEN x := -x END ;
  214.             S.class := 4; S.x := x
  215.           END ;
  216.           IF hex THEN S.class := 0 END
  217.         ELSE (*decimal integer*)
  218.           S.class := 3; k := 0;
  219.           REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
  220.           IF neg THEN S.i := -k ELSE S.i := k END;
  221.           IF hex THEN S.class := 0 ELSE S.class := 3 END
  222.         END
  223.       ELSE S.class := 6;
  224.         IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
  225.       END
  226.     END;
  227.     S.nextCh := ch
  228.   END Scan;
  229.  
  230.   (** Writers **)
  231.  
  232.   PROCEDURE OpenWriter* (VAR W: Writer);
  233.   BEGIN OpenBuf(W.buf)
  234.   END OpenWriter;
  235.  
  236.   PROCEDURE Write* (VAR W: Writer; ch: CHAR);
  237.     VAR B: Buffer;
  238.   BEGIN IF W.buf.len = BufLen THEN OpenBuf(B); B.next := W.buf; W.buf := B END;
  239.     W.buf.data[W.buf.len] := ch; INC(W.buf.len)
  240.   END Write;
  241.  
  242.   PROCEDURE WriteLn* (VAR W: Writer);
  243.   BEGIN Write(W, NL)
  244.   END WriteLn;
  245.  
  246.   PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
  247.     VAR i: INTEGER;
  248.   BEGIN i := 0;
  249.     WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
  250.   END WriteString;
  251.  
  252.   PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
  253.     VAR i: INTEGER; x0: LONGINT;
  254.       a: ARRAY 11 OF CHAR;
  255.   BEGIN i := 0;
  256.     IF x < 0 THEN
  257.       IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN
  258.       ELSE DEC(n); x0 := -x
  259.       END
  260.     ELSE x0 := x
  261.     END;
  262.     REPEAT
  263.       a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
  264.     UNTIL x0 = 0;
  265.     WHILE n > i DO Write(W, " "); DEC(n) END;
  266.     IF x < 0 THEN Write(W, "-") END;
  267.     REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
  268.   END WriteInt;
  269.  
  270.   PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
  271.     VAR i: INTEGER; y: LONGINT;
  272.       a: ARRAY 10 OF CHAR;
  273.   BEGIN i := 0; Write(W, " ");
  274.     REPEAT y := x MOD 10H;
  275.       IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
  276.       x := x DIV 10H; INC(i)
  277.     UNTIL i = 8;
  278.     REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
  279.   END WriteHex;
  280.  
  281.   PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
  282.     VAR e: INTEGER; x0: REAL;
  283.       d: ARRAY maxD OF CHAR;
  284.   BEGIN e := Reals.Expo(x);
  285.     IF e = 0 THEN
  286.       WriteString(W, "  0");
  287.       REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
  288.     ELSIF e = 255 THEN
  289.       WriteString(W, " NaN");
  290.       WHILE n > 4 DO Write(W, " "); DEC(n) END
  291.     ELSE
  292.       IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
  293.       REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
  294.       (*there are 2 < n <= 8 digits to be written*)
  295.       IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
  296.       e := (e - 127) * 77  DIV 256;
  297.       IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
  298.       IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
  299.       x0 := Reals.Ten(n-1); x := x0*x + 0.5;
  300.       IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
  301.       Reals.Convert(x, n, d);
  302.       DEC(n); Write(W, d[n]); Write(W, ".");
  303.       REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
  304.       Write(W, "E");
  305.       IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
  306.       Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
  307.     END
  308.   END WriteReal;
  309.  
  310.   PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
  311.     VAR e, i: INTEGER; sign: CHAR; x0: REAL;
  312.       d: ARRAY maxD OF CHAR;
  313.  
  314.     PROCEDURE seq(ch: CHAR; n: INTEGER);
  315.     BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
  316.     END seq;
  317.  
  318.     PROCEDURE dig(n: INTEGER);
  319.     BEGIN
  320.       WHILE n > 0 DO
  321.         DEC(i); Write(W, d[i]); DEC(n)
  322.       END
  323.     END dig;
  324.  
  325.   BEGIN e := Reals.Expo(x);
  326.     IF k < 0 THEN k := 0 END;
  327.     IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
  328.     ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
  329.     ELSE e := (e - 127) * 77 DIV 256;
  330.       IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
  331.       IF e >= 0 THEN  (*x >= 1.0,  77/256 = log 2*) x := x/Reals.Ten(e)
  332.         ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
  333.       END;
  334.       IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
  335.       (* 1 <= x < 10 *)
  336.       IF k+e >= maxD-1 THEN k := maxD-1-e
  337.         ELSIF k+e < 0 THEN k := -e; x := 0.0
  338.       END;
  339.       x0 := Reals.Ten(k+e); x := x0*x + 0.5;
  340.       IF x >= 10.0*x0 THEN INC(e) END;
  341.       (*e = no. of digits before decimal point*)
  342.       INC(e); i := k+e; Reals.Convert(x, i, d);
  343.       IF e > 0 THEN
  344.         seq(" ", n-e-k-2); Write(W, sign); dig(e);
  345.         Write(W, "."); dig(k)
  346.       ELSE seq(" ", n-k-3);
  347.         Write(W, sign); Write(W, "0"); Write(W, ".");
  348.         seq("0", -e); dig(k+e)
  349.       END
  350.     END
  351.   END WriteRealFix;
  352.  
  353.   PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
  354.     VAR i: INTEGER;
  355.       d: ARRAY 8 OF CHAR;
  356.   BEGIN Reals.ConvertH(x, d); i := 0;
  357.     REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
  358.   END WriteRealHex;
  359.  
  360.   PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
  361.     CONST maxD = 16;
  362.     VAR e: INTEGER; x0: LONGREAL;
  363.       d: ARRAY maxD OF CHAR;
  364.   BEGIN e := Reals.ExpoL(x);
  365.     IF e = 0 THEN
  366.       WriteString(W, "  0");
  367.       REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
  368.     ELSIF e = 2047 THEN
  369.       WriteString(W, " NaN");
  370.       WHILE n > 4 DO Write(W, " "); DEC(n) END
  371.     ELSE
  372.       IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
  373.       REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD;
  374.       (*there are 2 <= n <= maxD digits to be written*)
  375.       IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
  376.       e := SHORT(LONG(e - 1023) * 77 DIV 256);
  377.       IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ;
  378.       IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ;
  379.       x0 := Reals.TenL(n-1); x := x0*x + 0.5D0;
  380.       IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ;
  381.       Reals.ConvertL(x, n, d);
  382.       DEC(n); Write(W, d[n]); Write(W, ".");
  383.       REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
  384.       Write(W, "D");
  385.       IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
  386.       Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100;
  387.       Write(W, CHR(e DIV 10 + 30H));
  388.       Write(W, CHR(e MOD 10 + 30H))
  389.     END
  390.   END WriteLongReal;
  391.  
  392.   PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
  393.     VAR i: INTEGER;
  394.       d: ARRAY 16 OF CHAR;
  395.   BEGIN Reals.ConvertHL(x, d); i := 0;
  396.     REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
  397.   END WriteLongRealHex;
  398.  
  399.   PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
  400.  
  401.     PROCEDURE WritePair(ch: CHAR; x: LONGINT);
  402.     BEGIN Write(W, ch);
  403.       Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
  404.     END WritePair;
  405.  
  406.   BEGIN
  407.     WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
  408.     WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
  409.   END WriteDate;
  410.  
  411.   PROCEDURE Open* (VAR T: Text; name: ARRAY OF CHAR);
  412.   BEGIN T := Files.Old(name); 
  413.     IF T = NIL THEN T := Files.New(name) END
  414.   END Open;
  415.  
  416.   PROCEDURE Create* (VAR T: Text; name: ARRAY OF CHAR);
  417.   BEGIN T := Files.New(name)
  418.   END Create;
  419.  
  420.   PROCEDURE Close* (T: Text);
  421.   BEGIN Files.Close(T)
  422.   END Close;
  423.  
  424. END Texts.
  425.