Subversion Repositories Kolibri OS

Rev

Rev 7983 | Go to most recent revision | Show entire file | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 7983 Rev 8097
Line 1... Line 1...
1 
(*
 1 
(*
2 
    Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
 2 
    BSD 2-Clause License
Line 3... Line -...
3 
 
 - 
 
4 
    This program is free software: you can redistribute it and/or modify
 - 
 
5 
    it under the terms of the GNU Lesser General Public License as published by
 - 
 
6 
    the Free Software Foundation, either version 3 of the License, or
 3 
 
7 
    (at your option) any later version.
 - 
 
8 
 
 - 
 
9 
    This program is distributed in the hope that it will be useful,
 - 
 
10 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 - 
 
11 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 4 
    Copyright (c) 2020, Anton Krotov
12 
    GNU Lesser General Public License for more details.
 - 
 
13 
 
 - 
 
14 
    You should have received a copy of the GNU Lesser General Public License
 - 
 
15 
    along with this program.  If not, see .
 5 
    All rights reserved.
Line 16... Line 6...
16 
*)
 6 
*)
Line 17... Line 7...
17 
 
 7 
 
18 
MODULE Out;
 - 
 
19 
 
 - 
 
20 
IMPORT sys := SYSTEM;
 - 
 
21 
 
 - 
 
22 
CONST
 - 
 
23 
 
 - 
 
24 
  d = 1.0 - 5.0E-12;
 - 
 
25 
 
 - 
 
26 
TYPE
 - 
 
27 
 
 - 
 
28 
    POverlapped* = POINTER TO OVERLAPPED;
 - 
 
29 
 
 - 
 
30 
    OVERLAPPED* = RECORD
 - 
 
31 
 
 - 
 
32 
        Internal*:      INTEGER;
 - 
 
33 
        InternalHigh*:  INTEGER;
 - 
 
Line 34... Line -...
34 
        Offset*:        INTEGER;
 - 
 
Line 35... Line 8...
35 
        OffsetHigh*:    INTEGER;
 8 
MODULE Out;
Line 36... Line 9...
36 
        hEvent*:        INTEGER
 9 
 
37 
 
 - 
 
Line -... Line 10...
- 
 
 10 
IMPORT SYSTEM;
- 
 
 11 
 
- 
 
 12 
 
Line 38... Line -...
38 
    END;
 - 
 
39 
 
 - 
 
40 
VAR
 - 
 
41 
 
 13 
VAR
42 
  hConsoleOutput: INTEGER;
 14 
 
Line 43... Line 15...
43 
  Realp: PROCEDURE (x: REAL; width: INTEGER);
 15 
    hConsoleOutput: INTEGER;
44 
 
 16 
 
Line 45... Line 17...
45 
 
 17 
PROCEDURE [windows, "msvcrt.dll", "printf"] printf1 (fmt: INTEGER; x: INTEGER);
46 
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
 - 
 
47 
    GetStdHandle (nStdHandle: INTEGER): INTEGER;
 18 
PROCEDURE [windows, "msvcrt.dll", "printf"] printf2 (fmt: INTEGER; width, x: INTEGER);
48 
 
 19 
PROCEDURE [windows, "msvcrt.dll", "printf"] printf3 (fmt: INTEGER; width, precision, x: INTEGER);
49 
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
 20 
 
Line -... Line 21...
- 
 
 21 
PROCEDURE [windows, "kernel32.dll", ""]
50 
    WriteFile (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
 22 
    WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER);
51 
 
 - 
 
52 
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
 23 
 
53 
    WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
 24 
PROCEDURE [windows, "kernel32.dll", ""]
54 
 
 25 
    GetStdHandle (nStdHandle: INTEGER): INTEGER;
Line -... Line 26...
- 
 
 26 
 
55 
 
 27 
 
56 
PROCEDURE Char*(x: CHAR);
 - 
 
57 
VAR count: INTEGER;
 28 
PROCEDURE Char* (x: CHAR);
58 
BEGIN
 29 
BEGIN
59 
    WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
 - 
 
60 
END Char;
 - 
 
61 
 
 - 
 
62 
PROCEDURE StringW*(s: ARRAY OF WCHAR);
 30 
    printf1(SYSTEM.SADR("%c"), ORD(x))
Line 63... Line -...
63 
VAR count: INTEGER;
 - 
 
64 
BEGIN
 - 
 
65 
    WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
 - 
 
66 
END StringW;
 - 
 
67 
 
 - 
 
68 
PROCEDURE String*(s: ARRAY OF CHAR);
 - 
 
69 
VAR len, i: INTEGER;
 - 
 
70 
BEGIN
 - 
 
71 
    len := LENGTH(s);
 - 
 
72 
    FOR i := 0 TO len - 1 DO
 - 
 
73 
        Char(s[i])
 - 
 
74 
    END
 - 
 
75 
END String;
 - 
 
76 
 
 - 
 
77 
PROCEDURE WriteInt(x, n: INTEGER);
 - 
 
78 
VAR i: INTEGER; a: ARRAY 32 OF CHAR; neg: BOOLEAN;
 - 
 
79 
BEGIN
 - 
 
80 
  i := 0;
 - 
 
81 
  IF n < 1 THEN
 - 
 
82 
    n := 1
 - 
 
83 
  END;
 - 
 
84 
  IF x < 0 THEN
 - 
 
85 
    x := -x;
 - 
 
86 
    DEC(n);
 - 
 
87 
    neg := TRUE
 - 
 
88 
  END;
 - 
 
89 
  REPEAT
 - 
 
90 
    a[i] := CHR(x MOD 10 + ORD("0"));
 - 
 
91 
    x := x DIV 10;
 - 
 
Line 92... Line -...
92 
    INC(i)
 - 
 
93 
  UNTIL x = 0;
 31 
END Char;
94 
  WHILE n > i DO
 32 
 
95 
    Char(" ");
 - 
 
96 
    DEC(n)
 33 
 
97 
  END;
 34 
PROCEDURE StringW* (s: ARRAY OF WCHAR);
98 
  IF neg THEN
 35 
BEGIN
99 
    Char("-")
 - 
 
100 
  END;
 - 
 
101 
  REPEAT
 - 
 
Line 102... Line 36...
102 
    DEC(i);
 36 
    WriteConsoleW(hConsoleOutput, SYSTEM.ADR(s[0]), LENGTH(s), 0, 0)
103 
    Char(a[i])
 - 
 
104 
  UNTIL i = 0
 37 
END StringW;
105 
END WriteInt;
 - 
 
106 
 
 - 
 
107 
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
 - 
 
108 
VAR s: SET;
 38 
 
109 
BEGIN
 - 
 
110 
  sys.GET(sys.ADR(AValue), s)
 - 
 
111 
  RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
 - 
 
112 
END IsNan;
 - 
 
113 
 
 - 
 
114 
PROCEDURE IsInf(x: REAL): BOOLEAN;
 - 
 
115 
  RETURN ABS(x) = sys.INF()
 39 
 
Line 116... Line -...
116 
END IsInf;
 - 
 
117 
 
 - 
 
118 
PROCEDURE Int*(x, width: INTEGER);
 - 
 
119 
VAR i, minInt: INTEGER;
 - 
 
120 
BEGIN
 - 
 
121 
  minInt := 1;
 - 
 
122 
  minInt := ROR(minInt, 1);
 - 
 
123 
  IF x # minInt THEN
 - 
 
124 
    WriteInt(x, width)
 - 
 
125 
  ELSE
 - 
 
126 
    FOR i := 21 TO width DO
 - 
 
127 
      Char(20X)
 - 
 
128 
    END;
 - 
 
129 
    String("-9223372036854775808")
 - 
 
130 
  END
 - 
 
131 
END Int;
 - 
 
Line 132... Line 40...
132 
 
 40 
PROCEDURE String* (s: ARRAY OF CHAR);
133 
PROCEDURE OutInf(x: REAL; width: INTEGER);
 41 
BEGIN
134 
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
 42 
    printf2(SYSTEM.SADR("%.*s"), LENGTH(s), SYSTEM.ADR(s[0]))
135 
BEGIN
 - 
 
136 
  IF IsNan(x) THEN
 - 
 
Line 137... Line -...
137 
    s := "Nan";
 - 
 
138 
    INC(width)
 - 
 
139 
  ELSIF IsInf(x) & (x > 0.0) THEN
 43 
END String;
140 
    s := "+Inf"
 44 
 
141 
  ELSIF IsInf(x) & (x < 0.0) THEN
 - 
 
142 
    s := "-Inf"
 - 
 
143 
  END;
 - 
 
144 
  FOR i := 1 TO width - 4 DO
 - 
 
145 
    Char(" ")
 - 
 
146 
  END;
 - 
 
147 
  String(s)
 - 
 
148 
END OutInf;
 - 
 
149 
 
 - 
 
150 
PROCEDURE Ln*;
 - 
 
151 
BEGIN
 45 
 
152 
  Char(0DX);
 46 
PROCEDURE Ln*;
153 
  Char(0AX)
 - 
 
154 
END Ln;
 - 
 
155 
 
 - 
 
156 
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
 - 
 
157 
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
 47 
BEGIN
158 
BEGIN
 - 
 
159 
  IF IsNan(x) OR IsInf(x) THEN
 - 
 
160 
    OutInf(x, width)
 - 
 
161 
  ELSIF p < 0 THEN
 - 
 
162 
    Realp(x, width)
 - 
 
163 
  ELSE
 - 
 
164 
    len := 0;
 - 
 
165 
    minus := FALSE;
 - 
 
166 
    IF x < 0.0 THEN
 - 
 
167 
      minus := TRUE;
 - 
 
168 
      INC(len);
 - 
 
169 
      x := ABS(x)
 - 
 
170 
    END;
 - 
 
171 
    e := 0;
 - 
 
172 
    WHILE x >= 10.0 DO
 - 
 
173 
      x := x / 10.0;
 - 
 
174 
      INC(e)
 - 
 
175 
    END;
 - 
 
176 
 
 - 
 
177 
    IF e >= 0 THEN
 - 
 
178 
      len := len + e + p + 1;
 - 
 
179 
      IF x > 9.0 + d THEN
 - 
 
180 
        INC(len)
 - 
 
181 
      END;
 - 
 
182 
      IF p > 0 THEN
 - 
 
183 
        INC(len)
 - 
 
184 
      END;
 - 
 
185 
    ELSE
 - 
 
186 
      len := len + p + 2
 - 
 
187 
    END;
 - 
 
188 
    FOR i := 1 TO width - len DO
 - 
 
189 
      Char(" ")
 - 
 
190 
    END;
 - 
 
191 
    IF minus THEN
 - 
 
192 
      Char("-")
 - 
 
193 
    END;
 - 
 
194 
    y := x;
 - 
 
195 
    WHILE (y < 1.0) & (y # 0.0) DO
 - 
 
196 
      y := y * 10.0;
 - 
 
197 
      DEC(e)
 - 
 
198 
    END;
 - 
 
199 
    IF e < 0 THEN
 - 
 
200 
      IF x - FLT(FLOOR(x)) > d THEN
 - 
 
201 
        Char("1");
 - 
 
202 
        x := 0.0
 - 
 
203 
      ELSE
 - 
 
204 
        Char("0");
 - 
 
205 
        x := x * 10.0
 - 
 
206 
      END
 - 
 
207 
    ELSE
 - 
 
208 
      WHILE e >= 0 DO
 - 
 
209 
        IF x - FLT(FLOOR(x)) > d THEN
 - 
 
210 
          IF x > 9.0 THEN
 - 
 
211 
            String("10")
 - 
 
212 
          ELSE
 - 
 
213 
            Char(CHR(FLOOR(x) + ORD("0") + 1))
 - 
 
214 
          END;
 - 
 
215 
          x := 0.0
 - 
 
216 
        ELSE
 - 
 
217 
          Char(CHR(FLOOR(x) + ORD("0")));
 - 
 
218 
          x := (x - FLT(FLOOR(x))) * 10.0
 - 
 
Line 219... Line 48...
219 
        END;
 48 
    printf1(SYSTEM.SADR("%s"), SYSTEM.SADR(CHR(13) + CHR(10)))
220 
        DEC(e)
 - 
 
221 
      END
 49 
END Ln;
222 
    END;
 - 
 
223 
    IF p > 0 THEN
 - 
 
224 
      Char(".")
 - 
 
225 
    END;
 - 
 
226 
    WHILE p > 0 DO
 - 
 
227 
      IF x - FLT(FLOOR(x)) > d THEN
 - 
 
228 
        Char(CHR(FLOOR(x) + ORD("0") + 1));
 - 
 
229 
        x := 0.0
 - 
 
230 
      ELSE
 - 
 
231 
        Char(CHR(FLOOR(x) + ORD("0")));
 - 
 
232 
        x := (x - FLT(FLOOR(x))) * 10.0
 - 
 
233 
      END;
 - 
 
234 
      DEC(p)
 - 
 
235 
    END
 - 
 
236 
  END
 - 
 
237 
END _FixReal;
 - 
 
238 
 
 - 
 
239 
PROCEDURE Real*(x: REAL; width: INTEGER);
 - 
 
240 
VAR e, n, i: INTEGER; minus: BOOLEAN;
 - 
 
241 
BEGIN
 - 
 
242 
  Realp := Real;
 - 
 
243 
  IF IsNan(x) OR IsInf(x) THEN
 - 
 
244 
    OutInf(x, width)
 - 
 
245 
  ELSE
 - 
 
246 
    e := 0;
 - 
 
247 
    n := 0;
 - 
 
248 
    IF width > 23 THEN
 - 
 
249 
      n := width - 23;
 - 
 
250 
      width := 23
 - 
 
251 
    ELSIF width < 9 THEN
 - 
 
252 
      width := 9
 - 
 
253 
    END;
 - 
 
254 
    width := width - 5;
 - 
 
255 
    IF x < 0.0 THEN
 - 
 
256 
      x := -x;
 - 
 
257 
      minus := TRUE
 - 
 
258 
    ELSE
 - 
 
259 
      minus := FALSE
 50 
 
260 
    END;
 - 
 
261 
    WHILE x >= 10.0 DO
 - 
 
262 
      x := x / 10.0;
 - 
 
263 
      INC(e)
 - 
 
264 
    END;
 - 
 
265 
    WHILE (x < 1.0) & (x # 0.0) DO
 - 
 
266 
      x := x * 10.0;
 - 
 
267 
      DEC(e)
 - 
 
268 
    END;
 - 
 
269 
    IF x > 9.0 + d THEN
 - 
 
270 
      x := 1.0;
 - 
 
271 
      INC(e)
 - 
 
272 
    END;
 - 
 
273 
    FOR i := 1 TO n DO
 - 
 
274 
      Char(" ")
 - 
 
275 
    END;
 51 
 
Line -... Line 52...
- 
 
 52 
PROCEDURE Int* (x, width: INTEGER);
276 
    IF minus THEN
 53 
BEGIN
277 
      x := -x
 54 
    printf2(SYSTEM.SADR("%*lld"), width, x)
278 
    END;
 - 
 
279 
    _FixReal(x, width, width - 3);
 55 
END Int;
280 
    Char("E");
 56 
 
Line -... Line 57...
- 
 
 57 
 
281 
    IF e >= 0 THEN
 58 
PROCEDURE intval (x: REAL): INTEGER;
282 
      Char("+")
 59 
VAR
283 
    ELSE
 60 
    i: INTEGER;
284 
      Char("-");
 61 
 
Line -... Line 62...
- 
 
 62 
BEGIN
285 
      e := ABS(e)
 63 
    SYSTEM.GET(SYSTEM.ADR(x), i)
286 
    END;
 64 
    RETURN i