Subversion Repositories Kolibri OS

(*

    Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov

    This program is free software: you can redistribute it and/or modify

    it under the terms of the GNU Lesser General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    This program is distributed in the hope that it will be useful,

    but WITHOUT ANY WARRANTY; without even the implied warranty of

    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License

    along with this program.  If not, see .

*)

MODULE Out;

IMPORT sys := SYSTEM;

CONST

  d = 1.0 - 5.0E-12;

TYPE

    POverlapped* = POINTER TO OVERLAPPED;

    OVERLAPPED* = RECORD

        Internal*:      INTEGER;

        InternalHigh*:  INTEGER;

        Offset*:        INTEGER;

        OffsetHigh*:    INTEGER;

        hEvent*:        INTEGER

    END;

VAR

  hConsoleOutput: INTEGER;

  Realp: PROCEDURE (x: REAL; width: INTEGER);

PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]

    GetStdHandle (nStdHandle: INTEGER): INTEGER;

PROCEDURE [windows-, "kernel32.dll", "WriteFile"]

    WriteFile (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;

PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]

    WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;

PROCEDURE Char*(x: CHAR);

VAR count: INTEGER;

BEGIN

    WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)

END Char;

PROCEDURE StringW*(s: ARRAY OF WCHAR);

VAR count: INTEGER;

BEGIN

    WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)

END StringW;

PROCEDURE String*(s: ARRAY OF CHAR);

VAR len, i: INTEGER;

BEGIN

    len := LENGTH(s);

    FOR i := 0 TO len - 1 DO

        Char(s[i])

    END

END String;

PROCEDURE WriteInt(x, n: INTEGER);

VAR i: INTEGER; a: ARRAY 32 OF CHAR; neg: BOOLEAN;

BEGIN

  i := 0;

  IF n < 1 THEN

    n := 1

  END;

  IF x < 0 THEN

    x := -x;

    DEC(n);

    neg := TRUE

  END;

  REPEAT

    a[i] := CHR(x MOD 10 + ORD("0"));

    x := x DIV 10;

    INC(i)

  UNTIL x = 0;

  WHILE n > i DO

    Char(" ");

    DEC(n)

  END;

  IF neg THEN

    Char("-")

  END;

  REPEAT

    DEC(i);

    Char(a[i])

  UNTIL i = 0

END WriteInt;

PROCEDURE IsNan(AValue: REAL): BOOLEAN;

VAR s: SET;

BEGIN

  sys.GET(sys.ADR(AValue), s)

  RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))

END IsNan;

PROCEDURE IsInf(x: REAL): BOOLEAN;

  RETURN ABS(x) = sys.INF()

END IsInf;

PROCEDURE Int*(x, width: INTEGER);

VAR i, minInt: INTEGER;

BEGIN

  minInt := 1;

  minInt := ROR(minInt, 1);

  IF x # minInt THEN

    WriteInt(x, width)

  ELSE

    FOR i := 21 TO width DO

      Char(20X)

    END;

    String("-9223372036854775808")

  END

END Int;

PROCEDURE OutInf(x: REAL; width: INTEGER);

VAR s: ARRAY 5 OF CHAR; i: INTEGER;

BEGIN

  IF IsNan(x) THEN

    s := "Nan";

    INC(width)

  ELSIF IsInf(x) & (x > 0.0) THEN

    s := "+Inf"

  ELSIF IsInf(x) & (x < 0.0) THEN

    s := "-Inf"

  END;

  FOR i := 1 TO width - 4 DO

    Char(" ")

  END;

  String(s)

END OutInf;

PROCEDURE Ln*;

BEGIN

  Char(0DX);

  Char(0AX)

END Ln;

PROCEDURE _FixReal(x: REAL; width, p: INTEGER);

VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;

BEGIN

  IF IsNan(x) OR IsInf(x) THEN

    OutInf(x, width)

  ELSIF p < 0 THEN

    Realp(x, width)

  ELSE

    len := 0;

    minus := FALSE;

    IF x < 0.0 THEN

      minus := TRUE;

      INC(len);

      x := ABS(x)

    END;

    e := 0;

    WHILE x >= 10.0 DO

      x := x / 10.0;

      INC(e)

    END;

    IF e >= 0 THEN

      len := len + e + p + 1;

      IF x > 9.0 + d THEN

        INC(len)

      END;

      IF p > 0 THEN

        INC(len)

      END;

    ELSE

      len := len + p + 2

    END;

    FOR i := 1 TO width - len DO

      Char(" ")

    END;

    IF minus THEN

      Char("-")

    END;

    y := x;

    WHILE (y < 1.0) & (y # 0.0) DO

      y := y * 10.0;

      DEC(e)

    END;

    IF e < 0 THEN

      IF x - FLT(FLOOR(x)) > d THEN

        Char("1");

        x := 0.0

      ELSE

        Char("0");

        x := x * 10.0

      END

    ELSE

      WHILE e >= 0 DO

        IF x - FLT(FLOOR(x)) > d THEN

          IF x > 9.0 THEN

            String("10")

          ELSE

            Char(CHR(FLOOR(x) + ORD("0") + 1))

          END;

          x := 0.0

        ELSE

          Char(CHR(FLOOR(x) + ORD("0")));

          x := (x - FLT(FLOOR(x))) * 10.0

        END;

        DEC(e)

      END

    END;

    IF p > 0 THEN

      Char(".")

    END;

    WHILE p > 0 DO

      IF x - FLT(FLOOR(x)) > d THEN

        Char(CHR(FLOOR(x) + ORD("0") + 1));

        x := 0.0

      ELSE

        Char(CHR(FLOOR(x) + ORD("0")));

        x := (x - FLT(FLOOR(x))) * 10.0

      END;

      DEC(p)

    END

  END

END _FixReal;

PROCEDURE Real*(x: REAL; width: INTEGER);

VAR e, n, i: INTEGER; minus: BOOLEAN;

BEGIN

  Realp := Real;

  IF IsNan(x) OR IsInf(x) THEN

    OutInf(x, width)

  ELSE

    e := 0;

    n := 0;

    IF width > 23 THEN

      n := width - 23;

      width := 23

    ELSIF width < 9 THEN

      width := 9

    END;

    width := width - 5;

    IF x < 0.0 THEN

      x := -x;

      minus := TRUE

    ELSE

      minus := FALSE

    END;

    WHILE x >= 10.0 DO

      x := x / 10.0;

      INC(e)

    END;

    WHILE (x < 1.0) & (x # 0.0) DO

      x := x * 10.0;

      DEC(e)

    END;

    IF x > 9.0 + d THEN

      x := 1.0;

      INC(e)

    END;

    FOR i := 1 TO n DO

      Char(" ")

    END;

    IF minus THEN

      x := -x

    END;

    _FixReal(x, width, width - 3);

    Char("E");

    IF e >= 0 THEN

      Char("+")

    ELSE

      Char("-");

      e := ABS(e)

    END;

    IF e < 100 THEN

      Char("0")

    END;

    IF e < 10 THEN

      Char("0")

    END;

    Int(e, 0)

  END

END Real;

PROCEDURE FixReal*(x: REAL; width, p: INTEGER);

BEGIN

  Realp := Real;

  _FixReal(x, width, p)

END FixReal;

PROCEDURE Open*;

BEGIN

    hConsoleOutput := GetStdHandle(-11)

END Open;

END Out.