Gold Fish 3/goldfish_volume_3.bin/files/dev/obero/oberon-a/source/library/bufio.mod

Text File | 1995-01-25 | 11.2 KB | 371 lines

(***************************************************************************

     $RCSfile: BufIO.mod $
  Description: Simple formatted I/O using the standard input and output
               handles.

   Created by: fjc (Frank Copeland)
    $Revision: 1.1 $
      $Author: fjc $
        $Date: 1995/01/26 00:40:27 $

  Copyright © 1994, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

***************************************************************************)

<* STANDARD- *>

MODULE BufIO;

IMPORT  SYSTEM, Dos, Reals, WbConsole;

CONST   maxD = 9;

VAR     W, R: Dos.FileHandlePtr;


PROCEDURE Write* (fh: Dos.FileHandlePtr; ch: CHAR);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPutC (fh, ORD (ch)) = -1 THEN (* Error *) END
END Write;


PROCEDURE WriteLn* (fh: Dos.FileHandlePtr);
BEGIN
        Write (fh, "\n")
END WriteLn;


<*$CopyArrays-*>
PROCEDURE WriteStr* (fh: Dos.FileHandlePtr; str: ARRAY OF CHAR);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPuts (fh, str) THEN (* Error *) END
END WriteStr;


<*$CopyArrays-*>
PROCEDURE WriteF* (fh: Dos.FileHandlePtr; fs : ARRAY OF CHAR; VAR f : ARRAY OF SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.VFPrintf (fh, fs, f) = -1 THEN (* Error *) END
END WriteF;


<*$CopyArrays-*>
PROCEDURE WriteF1* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR; p1 : SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1) = -1 THEN (* Error *) END
END WriteF1;


<*$CopyArrays-*>
PROCEDURE WriteF2* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2) = -1 THEN (* Error *) END
END WriteF2;


<*$CopyArrays-*>
PROCEDURE WriteF3* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3) = -1 THEN (* Error *) END
END WriteF3;


<*$CopyArrays-*>
PROCEDURE WriteF4* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4) = -1 THEN (* Error *) END
END WriteF4;


<*$CopyArrays-*>
PROCEDURE WriteF6* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4, p5, p6: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6) = -1 THEN (* Error *) END
END WriteF6;


<*$CopyArrays-*>
PROCEDURE WriteF7* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4, p5, p6, p7: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7) = -1 THEN (* Error *) END
END WriteF7;


<*$CopyArrays-*>
PROCEDURE WriteF8* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4, p5, p6, p7, p8: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8) = -1 THEN (* Error *) END
END WriteF8;


<*$CopyArrays-*>
PROCEDURE WriteF9* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4, p5, p6, p7, p8, p9: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9) = -1 THEN (* Error *) END
END WriteF9;


<*$CopyArrays-*>
PROCEDURE WriteF10* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
                    p1, p2, p3, p4, p5, p6, p7, p8, p9, p10: SYSTEM.LONGWORD);
BEGIN
        IF fh = NIL THEN fh := W END;
        IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) = -1 THEN (* Error *) END
END WriteF10;


PROCEDURE WriteInt* (fh: Dos.FileHandlePtr; i: LONGINT);
BEGIN
        WriteF1 (fh, "%ld", i)
END WriteInt;


PROCEDURE WriteHex* (fh: Dos.FileHandlePtr; i : LONGINT);
BEGIN
        WriteF1 (fh, "%lx", i)
END WriteHex;


(*
 * The following WriteReal* and WriteLongReal* procedures have been pinched
 * from Module Texts and have been somewhat modified from the original code
 * described in "Project Oberon".
 *)

PROCEDURE WriteReal* (fh: Dos.FileHandlePtr; x: REAL; n: INTEGER );
VAR     e : INTEGER;
        x0: REAL;
        d : ARRAY maxD OF CHAR;
BEGIN
        (*
         * This implementation uses Motorola FFP format reals instead of IEEE
         * single-precision reals.  The Project Oberon code has been modified to
         * remove the special-case handling of unnormal and NaN values and assume
         * 7-bit exponents instead of 8-bit.
         *)
        e := Reals.Expo (x);
        IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
        REPEAT Write (fh, " "); DEC (n) UNTIL n <= 8;
        (* there are 2 < n <= 8 digits to be written *)
        IF x < 0.0 THEN Write (fh, "-"); x := -x ELSE Write (fh, " ") END;
        e := (e - 64) * 77 DIV 256;
        IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
        IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
        x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
        IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
        Reals.Convert (x, n, d);
        DEC (n); Write (fh, d [n]); Write (fh, ".");
        REPEAT DEC (n); Write (fh, d [n]) UNTIL n = 0;
        Write (fh, "E");
        IF e < 0 THEN Write (fh, "-"); e := -e ELSE Write (fh, "+") END;
        Write (fh, CHR (e DIV 10 + 30H)); Write (fh, CHR (e MOD 10 + 30H))
END WriteReal;


PROCEDURE WriteRealFix* (fh: Dos.FileHandlePtr; x: REAL; n, k: INTEGER);
VAR     e, i: INTEGER;
        sign: CHAR;
        x0: REAL;
        d : ARRAY maxD OF CHAR;

        PROCEDURE seq (ch: CHAR; n: LONGINT);
        BEGIN
                WHILE n > 0 DO Write (fh, ch); DEC (n) END
        END seq;

        PROCEDURE dig (n : INTEGER);
        BEGIN
                WHILE n > 0 DO
                        DEC (i); Write (fh, d [i]); DEC (n)
                END;
        END dig;

BEGIN   (*
         * This implementation uses Motorola FFP format reals instead of IEEE
         * single-precision reals.  The Project Oberon code has been modified to
         * remove the special-case handling of unnormal and NaN values and assume
         * 7-bit exponents instead of 8-bit.
         *)
        IF k < 0 THEN k := 0 END;
        e := (Reals.Expo (x) - 64) * 77 DIV 256;
        IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
        IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
        ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
        IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
        (* 1 <= x < 10 *)
        IF k + e >= maxD - 1 THEN k := maxD - 1 - e
        ELSIF k + e < 0 THEN k := -e; x := 0.0
        END;
        x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
        IF x >= 10.0 * x0 THEN INC (e) END;
        (* e = no. of digits before decimal point *)
        INC (e); i := k + e; Reals.Convert (x, i, d);
        IF e > 0 THEN
                seq (" ", n - e - k - 2); Write (fh, sign); dig (e); Write (fh, ".");
                dig (k)
        ELSE
                seq (" ", n - k - 3); Write (fh, sign); Write (fh, "0"); Write (fh, ".");
                seq ("0", -e); dig (k + e)
        END; (* ELSE *)
END WriteRealFix;


PROCEDURE WriteRealHex* (fh: Dos.FileHandlePtr; x: REAL);
VAR     d : ARRAY 9 OF CHAR;
BEGIN
        Reals.ConvertH (x, d); d [8] := 0X; WriteStr (fh, d)
END WriteRealHex;


PROCEDURE WriteLongReal* (fh: Dos.FileHandlePtr; x: LONGREAL; n: INTEGER);
BEGIN
        (*
         * In this implementation, LONGREAL and REAL types are the same, so this
         * procedure is implemented as a call to WriteReal ().
         *)
        WriteReal (fh, SHORT (x), n)
END WriteLongReal;


PROCEDURE WriteLongRealHex* (fh: Dos.FileHandlePtr; x: LONGREAL);
BEGIN
        (*
         * In this implementation, LONGREAL and REAL types are the same, so this
         * procedure is implemented as a call to WriteRealHex ().
         *)
        WriteRealHex (fh, SHORT (x))
END WriteLongRealHex;


PROCEDURE Read* (fh: Dos.FileHandlePtr; VAR ch : CHAR);
VAR     i: LONGINT;
BEGIN
        IF fh = NIL THEN fh := R END;
        i := Dos.FGetC (fh);
        IF i = -1 THEN
                ch := 0X
        ELSE    ch := CHR (SHORT (SHORT (i)))
        END
END Read;


PROCEDURE ReadStr* (fh: Dos.FileHandlePtr; VAR str : ARRAY OF CHAR);
VAR     ch: CHAR;
        index, limit: INTEGER;
BEGIN
        (* Skip white space *)
        REPEAT Read (fh, ch) UNTIL (ch # " ") & (ch # 09X);
        (* Read until control char *)
        index := 0; limit := SHORT (LEN (str));
        WHILE (ch >= " ") & (index < limit) DO
                str [index] := ch; INC (index); Read (fh, ch);
        END; (* WHILE *)
        str [index] := 0X;
        (* Skip rest of line if any *)
        WHILE ch >= " " DO Read (fh, ch) END
END ReadStr;


PROCEDURE ReadHexDigit (fh: Dos.FileHandlePtr; i: INTEGER): BOOLEAN;
VAR     ch: CHAR;
BEGIN
        Read (fh, ch);
        ch := CAP (ch);
        IF ("0" <= ch) & (ch <= "9") THEN
                i := ORD (ch) - ORD ("0")
        ELSIF ("A" <= ch) & (ch <= "F") THEN
                i := ORD (ch) - ORD ("A") + 10
        ELSE
                i := 0;
                IF Dos.UnGetC (fh, -1) = -1 THEN (* Error *) END;
                RETURN FALSE    (* error *)
        END;
        RETURN TRUE             (* success *)
END ReadHexDigit;


PROCEDURE ReadShortHex* (fh: Dos.FileHandlePtr; VAR i: SHORTINT): BOOLEAN;
VAR     n, j: INTEGER;
BEGIN
        i := 0;
        FOR n := 1 TO 2 DO
                IF ReadHexDigit (fh, j) THEN
                        i := i*16 + SHORT (j)
                ELSE    IF n > 1 THEN
                                RETURN TRUE
                        ELSE
                                RETURN FALSE    (* error *)
                        END
                END
        END;
        RETURN TRUE                     (* success *)
END ReadShortHex;


PROCEDURE ReadHex* (fh: Dos.FileHandlePtr; VAR i: INTEGER): BOOLEAN;
VAR     n, j: INTEGER;
BEGIN
        i := 0;
        FOR n := 1 TO 4 DO
                IF ReadHexDigit (fh, j) THEN
                        i := i*16 + j
                ELSE    IF n > 1 THEN
                                RETURN TRUE
                        ELSE
                                RETURN FALSE    (* error *)
                        END
                END
        END;
        RETURN TRUE                     (* success *)
END ReadHex;


PROCEDURE ReadLongHex* (fh: Dos.FileHandlePtr; VAR i: LONGINT): BOOLEAN;
VAR     n, j: INTEGER;
BEGIN
        i := 0;
        FOR n := 1 TO 8 DO
                IF ReadHexDigit (fh, j) THEN
                        i := i*16 + j
                ELSE    IF n > 1 THEN
                                RETURN TRUE
                        ELSE
                                RETURN FALSE    (* error *)
                        END
                END
        END;
        RETURN TRUE                     (* success *)
END ReadLongHex;


BEGIN   IF Dos.base.lib.version < 37 THEN
                SYSTEM.SETREG (0, Dos.Write (Dos.Output(), "Requires AmigaDOS version 2 or later.\n", 40));
                HALT (Dos.fail)
        END;
        W := Dos.Output ();
        R := Dos.Input ()
END BufIO.