DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
JVM: исправлен вызов локальных процедур вложенностью больше одного
[dsw-obn.git] / rtl / CPStrings.obn
1 MODULE CPStrings;
2 (**
3 Copyright (c) 2013 - 2016 BlackBox Framework Center
4 Copyright (c) 1994 - 2013 Oberon microsystems, Inc., Switzerland.
5 All rights reserved.
6
7 Redistribution and use in source and binary forms, with or without
8 modification, are permitted provided that the following conditions are met:
9 1. Redistributions of source code must retain the above copyright notice, this
10 list of conditions and the following disclaimer.
11 2. Redistributions in binary form must reproduce the above copyright notice,
12 this list of conditions and the following disclaimer in the documentation
13 and/or other materials provided with the distribution.
14
15 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
17 THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
19 LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 POSSIBILITY OF SUCH DAMAGE.
26
27 **)
28
29 (**
30 This module is adoptation from BlackBox 1.7 to Oberon-2 compilers.
31 Requires extension HUGEINT (64-bit integer).
32
33 Changes:
34 - Component Pascal types replaced with Oberon-2 equivalents.
35 - Removed Unicode support because it's depends on Kernel module.
36 - No capital "ÿ" because ISO 8859-1 doesn't support it.
37 - IN-parameters replaced with ordinary parameters.
38 - OUT-parameters replaced with VAR-parameters.
39
40 **)
41
42 IMPORT Strings, Math := CPMath;
43
44 CONST
45 charCode* = -1; decimal* = 10; hexadecimal* = -2; roman*= -3;
46 digitspace* = 08FX;
47 showBase* = TRUE; hideBase* = FALSE;
48 minLongIntRev = "8085774586302733229"; (* reversed string of -MIN(HUGEINT) *)
49
50 VAR
51 maxExp: LONGINT;
52 maxDig: LONGINT;
53 factor: LONGREAL; (* 10^maxDig *)
54 digits: ARRAY 17 OF CHAR;
55 toUpper, toLower: ARRAY 256 OF CHAR;
56
57 PROCEDURE Max (a, b : LONGINT) : LONGINT;
58 BEGIN
59 IF a > b THEN RETURN a ELSE RETURN b END
60 END Max;
61
62 (* integer conversions *)
63
64 PROCEDURE IntToString* (x: HUGEINT; VAR s: ARRAY OF CHAR);
65 VAR j, k: LONGINT; ch: CHAR; a: ARRAY 32 OF CHAR;
66 BEGIN
67 IF x # MIN(HUGEINT) THEN
68 IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
69 j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
70 ELSE
71 a := minLongIntRev; s[0] := "-"; k := 1;
72 j := 0; WHILE a[j] # 0X DO INC(j) END
73 END;
74 ASSERT(k + j < LEN(s), 23);
75 REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
76 s[k] := 0X
77 END IntToString;
78
79 PROCEDURE IntToStringForm* (x: HUGEINT; form, minWidth: LONGINT; fillCh: CHAR;
80 showBase: BOOLEAN; VAR s: ARRAY OF CHAR);
81 VAR base, i, j, k, si: LONGINT; mSign: BOOLEAN; a: ARRAY 128 OF CHAR; c1, c5, c10: CHAR;
82 BEGIN
83 ASSERT((form = charCode) OR (form = hexadecimal) OR (form = roman) OR ((form >= 2) & (form <= 16)), 20);
84 ASSERT(minWidth >= 0, 22);
85 IF form = charCode THEN base := 16
86 ELSIF form = hexadecimal THEN base := 16
87 ELSE base := form
88 END;
89
90 IF form = roman THEN
91 ASSERT((x > 0) & (x < 3999), 21);
92 base := 1000; i := 0; mSign := FALSE;
93 WHILE (base > 0) & (x > 0) DO
94 IF base = 1 THEN c1 := "I"; c5 := "V"; c10 := "X"
95 ELSIF base = 10 THEN c1 := "X"; c5 := "L"; c10 := "C"
96 ELSIF base = 100 THEN c1 := "C"; c5 := "D"; c10 := "M"
97 ELSE c1 := "M"
98 END;
99 k := SHORT(x DIV base); x := x MOD base;
100 IF k IN {4, 9} THEN a[i] := c1; INC(i) END;
101 IF k IN {4 .. 8} THEN a[i] := c5; INC(i) END;
102 IF k = 9 THEN a[i] := c10; INC(i)
103 ELSIF k IN {1 .. 3, 6 .. 8} THEN
104 j := k MOD 5;
105 REPEAT a[i] := c1; INC(i); DEC(j) UNTIL j = 0
106 END;
107 base := base DIV 10
108 END
109 ELSIF (form = hexadecimal) OR (form = charCode) THEN
110 i := 0; mSign := FALSE;
111 IF showBase THEN DEC(minWidth) END;
112 REPEAT
113 a[i] := digits[x MOD base]; x := x DIV base; INC(i)
114 UNTIL (x = 0) OR (x = -1) OR (i = LEN(a));
115 IF x = -1 THEN fillCh := "F" END
116 ELSE
117 IF x < 0 THEN
118 i := 0; mSign := TRUE; DEC(minWidth);
119 REPEAT
120 IF x MOD base = 0 THEN
121 a[i] := digits[0]; x := x DIV base
122 ELSE
123 a[i] := digits[base - x MOD base]; x := x DIV base + 1
124 END;
125 INC(i)
126 UNTIL (x = 0) OR (i = LEN(a))
127 ELSE
128 i := 0; mSign := FALSE;
129 REPEAT
130 a[i] := digits[x MOD base]; x := x DIV base; INC(i)
131 UNTIL (x = 0) OR (i = LEN(a))
132 END;
133 IF showBase THEN DEC(minWidth);
134 IF base < 10 THEN DEC(minWidth) ELSE DEC(minWidth,2) END
135 END
136 END;
137 si := 0;
138 IF mSign & (fillCh = "0") & (si < LEN(s)) THEN s[si] := "-"; INC(si); mSign := FALSE END;
139 WHILE minWidth > i DO
140 IF si < LEN(s) THEN s[si] := fillCh; INC(si) END;
141 DEC(minWidth)
142 END;
143 IF mSign & (si < LEN(s)) THEN s[si] := "-"; INC(si) END;
144 IF form = roman THEN
145 j := 0;
146 WHILE j < i DO
147 IF si < LEN(s) THEN s[si] := a[j]; INC(si) END;
148 INC(j)
149 END
150 ELSE
151 REPEAT DEC(i);
152 IF si < LEN(s) THEN s[si] := a[i]; INC(si) END
153 UNTIL i = 0
154 END;
155 IF showBase & (form # roman) THEN
156 IF (form = charCode) & (si < LEN(s)) THEN s[si] := "X"; INC(si)
157 ELSIF (form = hexadecimal) & (si < LEN(s)) THEN s[si] := "H"; INC(si)
158 ELSIF (form < 10) & (si < LEN(s)-1) THEN s[si] := "%"; s[si+1] := digits[base]; INC(si, 2)
159 ELSIF (si < LEN(s) - 2) THEN
160 s[si] := "%"; s[si+1] := digits[base DIV 10]; s[si+2] := digits[base MOD 10]; INC(si, 3)
161 END
162 END;
163 IF si < LEN(s) THEN s[si] := 0X ELSE HALT(23) END
164 END IntToStringForm;
165
166 PROCEDURE StringToInt* (s: ARRAY OF CHAR; VAR x: LONGINT; VAR res: LONGINT);
167 CONST hexLimit = MAX(LONGINT) DIV 8 + 1;
168 VAR i, j, k, digits: LONGINT; ch, top: CHAR; neg: BOOLEAN; base: LONGINT;
169 BEGIN
170 res := 0; i := 0; ch := s[0];
171 WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO (* ignore leading blanks *)
172 INC(i); ch := s[i]
173 END;
174 j := i; top := "0";
175 WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO
176 IF ch > top THEN top := ch END;
177 INC(j); ch := s[j]
178 END;
179 IF (ch = "H") OR (ch = "X") THEN
180 x := 0; ch := s[i];
181 IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
182 WHILE ch = "0" DO INC(i); ch := s[i] END;
183 digits := 0;
184 WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO
185 IF ch < "A" THEN k := ORD(ch) - ORD("0")
186 ELSE k := ORD(ch) - ORD("A") + 10
187 END;
188 IF digits < 8 THEN
189 x := x MOD hexLimit;
190 IF x >= hexLimit DIV 2 THEN x := x - hexLimit END;
191 x := x * 16 + k; INC(i); ch := s[i]
192 ELSE res := 1
193 END;
194 INC(digits)
195 END;
196 IF res = 0 THEN
197 IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END
198 END
199 ELSE res := 2
200 END
201 ELSE
202 IF ch = "%" THEN
203 INC(j); ch := s[j]; base := 0;
204 IF ("0" <= ch) & (ch <= "9") THEN
205 k := ORD(ch) - ORD("0");
206 REPEAT
207 base := base * 10 + k;
208 INC(j); ch := s[j]; k := ORD(ch) - ORD("0")
209 UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(LONGINT) - k) DIV 10);
210 IF ("0" <= ch) & (ch <= "9") THEN base := 0 END
211 END
212 ELSE
213 base := 10
214 END;
215
216 IF (base < 2) OR (base > 16) THEN
217 res := 2
218 ELSIF (base <= 10) & (ORD(top) < base + ORD("0"))
219 OR (base > 10) & (ORD(top) < base - 10 + ORD("A")) THEN
220 x := 0; ch := s[i]; neg := FALSE;
221 IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END;
222 WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END;
223 IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
224 IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END;
225 WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO
226 IF x >= (MIN(LONGINT) + (base - 1) + k) DIV base THEN
227 x := x * base - k; INC(i); ch := s[i];
228 IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END
229 ELSE res := 1
230 END
231 END
232 ELSE res := 2
233 END;
234 IF res = 0 THEN
235 IF ~neg THEN
236 IF x > MIN(LONGINT) THEN x := -x ELSE res := 1 END
237 END;
238 IF (ch # 0X) & (ch # "%") THEN res := 2 END
239 END
240 ELSE
241 res := 2
242 END
243 END
244 END StringToInt;
245
246 PROCEDURE StringToLInt* (s: ARRAY OF CHAR; VAR x: HUGEINT; VAR res: LONGINT);
247 CONST hexLimit = MAX(HUGEINT) DIV 8 + 1;
248 VAR i, j, k, digits: LONGINT; ch, top: CHAR; neg: BOOLEAN; base: LONGINT;
249 BEGIN
250 res := 0; i := 0; ch := s[0];
251 WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO (* ignore leading blanks *)
252 INC(i); ch := s[i]
253 END;
254 j := i; top := "0";
255 WHILE (ch # 0X) & (ch # "H") & (ch # "X") & (ch # "%") DO
256 IF ch > top THEN top := ch END;
257 INC(j); ch := s[j]
258 END;
259 IF (ch = "H") OR (ch = "X") THEN
260 x := 0; ch := s[i];
261 IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
262 WHILE ch = "0" DO INC(i); ch := s[i] END;
263 digits := 0;
264 WHILE (res = 0) & (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) DO
265 IF ch < "A" THEN k := ORD(ch) - ORD("0")
266 ELSE k := ORD(ch) - ORD("A") + 10
267 END;
268 IF digits < 16 THEN
269 x := x MOD hexLimit;
270 IF x >= hexLimit DIV 2 THEN x := x - hexLimit END;
271 x := x * 16 + k; INC(i); ch := s[i]
272 ELSE res := 1
273 END;
274 INC(digits)
275 END;
276 IF res = 0 THEN
277 IF (ch # "H") & (ch # "X") OR (s[i+1] # 0X) THEN res := 2 END
278 END
279 ELSE res := 2
280 END
281 ELSE
282 IF ch = "%" THEN
283 INC(j); ch := s[j]; base := 0;
284 IF ("0" <= ch) & (ch <= "9") THEN
285 k := ORD(ch) - ORD("0");
286 REPEAT
287 base := base * 10 + k;
288 INC(j); ch := s[j]; k := ORD(ch) - ORD("0")
289 UNTIL (ch < "0") OR (ch > "9") OR (base > (MAX(LONGINT) - k) DIV 10);
290 IF ("0" <= ch) & (ch <= "9") THEN base := 0 END
291 END
292 ELSE
293 base := 10
294 END;
295
296 IF (base < 2) OR (base > 16) THEN
297 res := 2
298 ELSIF (base <= 10) & (ORD(top) < base + ORD("0"))
299 OR (base > 10) & (ORD(top) < base -10 + ORD("A")) THEN
300 x := 0; ch := s[i]; neg := FALSE;
301 IF ch = "-" THEN INC(i); ch := s[i]; neg := TRUE ELSIF ch = "+" THEN INC(i); ch := s[i] END;
302 WHILE (ch # 0X) & (ch <= " ") DO INC(i); ch := s[i] END;
303 IF ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") THEN
304 IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END;
305 WHILE (("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F")) & (res = 0) DO
306 IF x >= (MIN(HUGEINT) + (base - 1) + k) DIV base THEN
307 x := x * base - k; INC(i); ch := s[i];
308 IF ch <= "9" THEN k := ORD(ch) - ORD("0") ELSE k := ORD(ch) - ORD("A") + 10 END
309 ELSE res := 1
310 END
311 END
312 ELSE res := 2
313 END;
314 IF res = 0 THEN
315 IF ~neg THEN
316 IF x > MIN(HUGEINT) THEN x := -x ELSE res := 1 END
317 END;
318 IF (ch # 0X) & (ch # "%") THEN res := 2 END
319 END
320 ELSE
321 res := 2
322 END
323 END
324 END StringToLInt;
325
326
327 (* real conversions *)
328
329 PROCEDURE RealToStringForm* (x: LONGREAL; precision, minW, expW: LONGINT; fillCh: CHAR;
330 VAR s: ARRAY OF CHAR);
331 VAR exp, len, i, j, n, k, p: LONGINT; m: ARRAY 80 OF CHAR; neg: BOOLEAN;
332 BEGIN
333 ASSERT((precision > 0) (*& (precision <= 18)*), 20);
334 ASSERT((minW >= 0) & (minW < LEN(s)), 21);
335 ASSERT((expW > -LEN(s)) & (expW <= 3), 22);
336 exp := Math.Exponent(x);
337 IF exp = MAX(LONGINT) THEN
338 IF fillCh = "0" THEN fillCh := digitspace END;
339 x := Math.Mantissa(x);
340 IF x = -1 THEN m := "-inf"; n := 4
341 ELSIF x = 1 THEN m := "inf"; n := 3
342 ELSE m := "nan"; n := 3
343 END;
344 i := 0; j := 0;
345 WHILE minW > n DO s[i] := fillCh; INC(i); DEC(minW) END;
346 WHILE (j <= n) & (i < LEN(s)) DO s[i] := m[j]; INC(i); INC(j) END
347 ELSE
348 neg := FALSE; len := 1; m := "00";
349 IF x < 0 THEN x := -x; neg := TRUE; DEC(minW) END;
350 IF x # 0 THEN
351 exp := (exp - 8) * 30103 DIV 100000; (* * log(2) *)
352 IF exp > 0 THEN
353 n := SHORT(ENTIER(x / Math.IntPower(10, exp)));
354 x := x / Math.IntPower(10, exp) - n
355 ELSIF exp > -maxExp THEN
356 n := SHORT(ENTIER(x * Math.IntPower(10, -exp)));
357 x := x * Math.IntPower(10, -exp) - n
358 ELSE
359 n := SHORT(ENTIER(x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor));
360 x := x * Math.IntPower(10, -exp - 2 * maxDig) * factor * factor - n
361 END;
362 (* x0 = (n + x) * 10^exp, 200 < n < 5000 *)
363 p := precision - 4;
364 IF n < 1000 THEN INC(p) END;
365 IF (expW < 0) & (p > exp - expW) THEN p := exp - expW END;
366 IF p >= 0 THEN
367 x := x + 0.5 / Math.IntPower(10, p); (* rounding correction *)
368 IF x >= 1 THEN INC(n); x := x - 1 END
369 ELSIF p = -1 THEN INC(n, 5)
370 ELSIF p = -2 THEN INC(n, 50)
371 ELSIF p = -3 THEN INC(n, 500)
372 END;
373 i := 0; k := 1000; INC(exp, 3);
374 IF n < 1000 THEN k := 100; DEC(exp) END;
375 WHILE (i < precision) & ((k > 0) OR (x # 0)) DO
376 IF k > 0 THEN p := n DIV k; n := n MOD k; k := k DIV 10
377 ELSE x := x * 10; p := SHORT(ENTIER(x)); x := x - p
378 END;
379 m[i] := CHR(p + ORD("0")); INC(i);
380 IF p # 0 THEN len := i END
381 END
382 END;
383 (* x0 = m[0].m[1]...m[len-1] * 10^exp *)
384 i := 0;
385 IF (expW < 0) OR (expW = 0) & (exp >= -3) & (exp <= len + 1) THEN
386 n := exp + 1; k := len - n;
387 IF n < 1 THEN n := 1 END;
388 IF expW < 0 THEN k := -expW ELSIF k < 1 THEN k := 1 END;
389 j := minW - n - k - 1; p := -exp;
390 IF neg & (p >= Max(0, n) + Max(0, k)) THEN neg := FALSE; INC(j) END
391 ELSE
392 IF ABS(exp) >= 100 THEN expW := 3
393 ELSIF (expW < 2) & (ABS(exp) >= 10) THEN expW := 2
394 ELSIF expW < 1 THEN expW := 1
395 END;
396 IF len < 2 THEN len := 2 END;
397 j := minW - len - 3 - expW; k := len;
398 IF j > 0 THEN
399 k := k + j; j := 0;
400 IF k > precision THEN j := k - precision; k := precision END
401 END;
402 n := 1; DEC(k); p := 0
403 END;
404 IF neg & (fillCh = "0") THEN s[i] := "-"; INC(i); neg := FALSE END;
405 WHILE j > 0 DO s[i] := fillCh; INC(i); DEC(j) END;
406 IF neg & (i < LEN(s)) THEN s[i] := "-"; INC(i) END;
407 j := 0;
408 WHILE (n > 0) & (i < LEN(s)) DO
409 IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END;
410 INC(i); DEC(n); DEC(p)
411 END;
412 IF i < LEN(s) THEN s[i] := "."; INC(i) END;
413 WHILE (k > 0) & (i < LEN(s)) DO
414 IF (p <= 0) & (j < len) THEN s[i] := m[j]; INC(j) ELSE s[i] := "0" END;
415 INC(i); DEC(k); DEC(p)
416 END;
417 IF expW > 0 THEN
418 IF i < LEN(s) THEN s[i] := "E"; INC(i) END;
419 IF i < LEN(s) THEN
420 IF exp < 0 THEN s[i] := "-"; exp := -exp ELSE s[i] := "+" END;
421 INC(i)
422 END;
423 IF (expW = 3) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 100 + ORD("0")); INC(i) END;
424 IF (expW >= 2) & (i < LEN(s)) THEN s[i] := CHR(exp DIV 10 MOD 10 + ORD("0")); INC(i) END;
425 IF i < LEN(s) THEN s[i] := CHR(exp MOD 10 + ORD("0")); INC(i) END
426 END
427 END;
428 IF i < LEN(s) THEN s[i] := 0X ELSE HALT(23) END
429 END RealToStringForm;
430
431 PROCEDURE RealToString* (x: LONGREAL; VAR s: ARRAY OF CHAR);
432 BEGIN
433 RealToStringForm(x, 16, 0, 0, digitspace, s)
434 END RealToString;
435
436
437 PROCEDURE StringToReal* (s: ARRAY OF CHAR; VAR x: LONGREAL; VAR res: LONGINT);
438 VAR first, last, point, e, n, i, exp: LONGINT; y: LONGREAL; ch: CHAR; neg, negExp, dig: BOOLEAN;
439 BEGIN
440 res := 0; i := 0; ch := s[0]; dig := FALSE;
441 WHILE (ch # 0X) & (ch <= " ") OR (ch = 8BX) OR (ch = 8FX) OR (ch = 0A0X) DO INC(i); ch := s[i] END;
442 IF ch = "+" THEN
443 neg := FALSE; INC(i); ch := s[i]
444 ELSIF ch = "-" THEN
445 neg := TRUE; INC(i); ch := s[i]
446 ELSE
447 neg := FALSE
448 END;
449 WHILE ch = "0" DO INC(i); ch := s[i]; dig := TRUE END;
450 first := i; e := 0;
451 WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; INC(e); dig := TRUE END;
452 point := i;
453 IF ch = "." THEN
454 INC(i); ch := s[i];
455 IF e = 0 THEN
456 WHILE ch = "0" DO INC(i); ch := s[i]; DEC(e); dig := TRUE END;
457 first := i
458 END;
459 WHILE ("0" <= ch) & (ch <= "9") DO INC(i); ch := s[i]; dig := TRUE END
460 END;
461 last := i - 1; exp := 0;
462 IF (ch = "E") OR (ch = "D") THEN
463 INC(i); ch := s[i]; negExp := FALSE;
464 IF ch = "-" THEN negExp := TRUE; INC(i); ch := s[i]
465 ELSIF ch = "+" THEN INC(i); ch := s[i]
466 END;
467 WHILE ("0" <= ch) & (ch <= "9") & (exp < 1000) DO
468 exp := exp * 10 + (ORD(ch) - ORD("0"));
469 INC(i); ch := s[i]
470 END;
471 IF negExp THEN exp := -exp END
472 END;
473 exp := exp + e; x := 0; y := 0; n := 0;
474 WHILE (n < maxDig) & (first <= last) DO
475 IF first # point THEN x := x * 10 + (ORD(s[first]) - ORD("0")); INC(n) END;
476 INC(first)
477 END;
478 WHILE last >= first DO
479 IF last # point THEN y := (y + (ORD(s[last]) - ORD("0"))) / 10 END;
480 DEC(last)
481 END;
482 IF ~dig OR (ch # 0X) THEN res := 2 (* syntax error *)
483 ELSIF exp < -maxExp - maxDig THEN
484 x := 0.0
485 ELSIF exp < -maxExp + maxDig THEN
486 x := (x + y) / Math.IntPower(10, n - exp - 2 * maxDig) / factor / factor
487 ELSIF exp < n THEN
488 x := (x + y) / Math.IntPower(10, n - exp)
489 ELSIF exp < maxExp THEN
490 x := (x + y) * Math.IntPower(10, exp - n)
491 ELSIF exp = maxExp THEN
492 x := (x + y) * (Math.IntPower(10, exp - n) / 16);
493 IF x <= MAX(LONGREAL) / 16 THEN x := x * 16
494 ELSE res := 1 (* overflow *)
495 END
496 ELSE res := 1 (* overflow *)
497 END;
498 IF neg THEN x := -x END
499 END StringToReal;
500
501
502 (* set conversions *)
503
504 PROCEDURE SetToString* (x: SET; VAR str: ARRAY OF CHAR);
505 VAR
506 len, i: LONGINT;
507
508 PROCEDURE AppendChar(ch: CHAR);
509 BEGIN ASSERT(len < LEN(str), 23); str[len] := ch; INC(len)
510 END AppendChar;
511
512 PROCEDURE AppendInt (x: LONGINT);
513 VAR i: LONGINT; ch: CHAR; buf: ARRAY 32 OF CHAR;
514 BEGIN
515 IntToString(x, buf);
516 ch := buf[0]; i := 0;
517 WHILE ch # 0X DO AppendChar(ch); INC(i); ch := buf[i] END
518 END AppendInt;
519
520 BEGIN
521 len := 0; AppendChar('{'); i := MIN(SET);
522 WHILE x # {} DO
523 IF i IN x THEN AppendInt(i); EXCL(x, i);
524 IF (i <= MAX(SET) - 2) & (i+1 IN x) & (i+2 IN x) THEN AppendChar('.'); AppendChar('.');
525 x := x - {i+1, i+2}; INC(i, 3);
526 WHILE (i <= MAX(SET)) & (i IN x) DO EXCL(x, i); INC(i) END;
527 AppendInt(i-1)
528 END;
529 IF x # {} THEN AppendChar(","); AppendChar(" ") END
530 END;
531 INC(i)
532 END;
533 AppendChar("}"); AppendChar(0X)
534 END SetToString;
535
536 PROCEDURE StringToSet* (s: ARRAY OF CHAR; VAR x: SET; VAR res: LONGINT);
537 VAR
538 next, x1: LONGINT; ch: CHAR;
539
540 PROCEDURE NextChar;
541 BEGIN ch := s[next];
542 WHILE (ch <= " ") & (ch # 0X) DO INC(next); ch := s[next] END ;
543 IF ch # 0X THEN INC(next) END
544 END NextChar;
545
546 PROCEDURE ParseInt(): LONGINT;
547 VAR intval: LONGINT;
548 BEGIN
549 intval := ORD(ch) - ORD("0");
550 ch := s[next];
551 WHILE ("0" <= ch) & (ch <= "9") DO
552 intval := intval * 10 + ORD(ch) - ORD('0');
553 IF intval > MAX(SET) THEN res := 1; intval := 0 END ;
554 INC(next); ch := s[next]
555 END ;
556 NextChar;
557 RETURN intval
558 END ParseInt;
559
560 PROCEDURE ParseRange();
561 VAR x2, i: LONGINT;
562 BEGIN
563 ch := s[next]; INC(next);
564 IF ch = "." THEN NextChar;
565 IF ("0" <= ch) & (ch <= "9") THEN x2 := ParseInt();
566 IF res = 0 THEN
567 IF x2 >= x1 THEN FOR i := x1 TO x2 DO INCL(x, i) END
568 ELSE res := 2
569 END
570 END
571 ELSE res := 2
572 END
573 ELSE res := 2
574 END
575 END ParseRange;
576
577 BEGIN
578 x := {}; res := 0; next := 0; NextChar;
579 IF ch = "{" THEN
580 NextChar;
581 WHILE ("0" <= ch) & (ch <= "9") & (res # 2) DO
582 x1 := ParseInt();
583 IF ch = "." THEN ParseRange() ELSIF res = 0 THEN INCL(x, x1) END ;
584 IF ch = "," THEN NextChar END
585 END ;
586 IF ch = "}" THEN NextChar;
587 IF ch # 0X THEN res := 2 END
588 ELSE res := 2
589 END
590 ELSE res := 2
591 END
592 END StringToSet;
593
594 (* ----------------------------- general purpose character classes and conversions --------------------------- *)
595
596 PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
597 BEGIN
598 RETURN toLower[ORD(ch)] # ch
599 END IsUpper;
600
601 PROCEDURE Upper* (ch: CHAR): CHAR;
602 BEGIN
603 RETURN toUpper[ORD(ch)]
604 END Upper;
605
606 PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
607 BEGIN
608 RETURN toUpper[ORD(ch)] # ch
609 END IsLower;
610
611 PROCEDURE Lower* (ch: CHAR): CHAR;
612 BEGIN
613 RETURN toLower[ORD(ch)]
614 END Lower;
615
616 PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN;
617 BEGIN
618 CASE ch OF
619 "a".."z", "A".."Z": RETURN TRUE
620 ELSE
621 RETURN FALSE
622 END
623 END IsAlpha;
624
625 PROCEDURE IsNumeric* (ch: CHAR): BOOLEAN;
626 BEGIN
627 RETURN ("0" <= ch) & (ch <= "9")
628 END IsNumeric;
629
630 PROCEDURE IsAlphaNumeric* (ch: CHAR): BOOLEAN;
631 BEGIN
632 RETURN IsAlpha(ch) OR IsNumeric(ch)
633 END IsAlphaNumeric;
634
635 (* ----------------------------- Component Pascal character classes --------------------------- *)
636
637 PROCEDURE IsIdentStart* (ch: CHAR): BOOLEAN;
638 BEGIN
639 CASE ch OF
640 "a".."z", "A".."Z", "_": RETURN TRUE
641 ELSE
642 RETURN FALSE
643 END
644 END IsIdentStart;
645
646 PROCEDURE IsIdent* (ch: CHAR): BOOLEAN;
647 BEGIN
648 (* returns IsIdentStart(ch) OR IsNumeric(ch); optimized because heavily used in the compiler *)
649 CASE ch OF
650 "a".."z", "A".."Z", "_", "0".."9": RETURN TRUE
651 ELSE
652 RETURN FALSE
653 END
654 END IsIdent;
655
656 (* ----------------------------- string manipulation routines --------------------------- *)
657
658 PROCEDURE Valid* (s: ARRAY OF CHAR): BOOLEAN;
659 VAR i: LONGINT;
660 BEGIN i := 0;
661 WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
662 RETURN i < LEN(s)
663 END Valid;
664
665 PROCEDURE ToUpper* (in: ARRAY OF CHAR; VAR out: ARRAY OF CHAR);
666 VAR i, max: LONGINT;
667 BEGIN i := 0; max := LEN(out)-1;
668 WHILE (in[i] # 0X) & (i < max) DO
669 out[i] := toUpper[ORD(in[i])];
670 INC(i)
671 END;
672 out[i] := 0X
673 END ToUpper;
674
675 PROCEDURE ToLower* (in: ARRAY OF CHAR; VAR out: ARRAY OF CHAR);
676 VAR i, max: LONGINT;
677 BEGIN i := 0; max := LEN(out)-1;
678 WHILE (in[i] # 0X) & (i < max) DO
679 out[i] := toLower[ORD(in[i])];
680 INC(i)
681 END;
682 out[i] := 0X
683 END ToLower;
684
685 PROCEDURE Replace* (VAR s: ARRAY OF CHAR; pos, len: LONGINT; rep: ARRAY OF CHAR);
686 (* replace stretch s[pos]..s[pos+len-1] with rep *)
687 (* insert semantics if len = 0; delete semantics if Length(rep) = 0 *)
688 VAR i, j, k, max, lenS: LONGINT; ch: CHAR;
689 BEGIN
690 ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21);
691 lenS := Strings.Length(s); max := LEN(s) - 1;
692 IF pos <= lenS THEN i := pos; j := 0; ch := rep[0];
693 IF pos+len > lenS THEN len := lenS - pos END;
694 WHILE (ch # 0X) & (len > 0) DO
695 s[i] := ch; INC(i); INC(j); DEC(len); ch := rep[j]
696 END;
697 IF len > 0 THEN (* delete the remaining part of the stretch [pos, pos+len') *)
698 REPEAT ch := s[i+len]; s[i] := ch; INC(i) UNTIL ch = 0X
699 ELSIF ch # 0X THEN (* insert the remaining part of rep *)
700 len := Strings.Length(rep) - j; k := lenS + len;
701 IF k > max THEN k := max END;
702 s[k] := 0X; DEC(k);
703 WHILE k - len >= i DO s[k] := s[k-len]; DEC(k) END;
704 WHILE (rep[j] # 0X) & (i < max) DO s[i] := rep[j]; INC(i); INC(j) END
705 END
706 END
707 END Replace;
708
709 PROCEDURE Extract* (s: ARRAY OF CHAR; pos, len: LONGINT; VAR res: ARRAY OF CHAR);
710 VAR i, j, max: LONGINT;
711 BEGIN
712 ASSERT(len >= 0, 20); ASSERT(pos >= 0, 21);
713 i := 0; j := 0; max := LEN(res) - 1;
714 WHILE (i < pos) & (s[i] # 0X) DO INC(i) END;
715 WHILE (j < len) & (j < max) & (s[i] # 0X) DO res[j] := s[i]; INC(j); INC(i) END;
716 res[j] := 0X
717 END Extract;
718
719 PROCEDURE Find* (s: ARRAY OF CHAR; pat: ARRAY OF CHAR; start: LONGINT; VAR pos: LONGINT);
720 VAR j: LONGINT;
721 BEGIN
722 ASSERT(start >= 0, 20);
723 IF (start = 0) OR (start <= Strings.Length(s) - Strings.Length(pat)) THEN
724 (* start = 0 is optimization: need not call Len *)
725 pos := start;
726 WHILE s[pos] # 0X DO j := 0;
727 WHILE (s[pos+j] = pat[j]) & (pat[j] # 0X) DO INC(j) END;
728 IF pat[j] = 0X THEN RETURN END;
729 INC(pos)
730 END
731 END;
732 pos := -1 (* pattern not found *)
733 END Find;
734
735 PROCEDURE Init;
736 VAR i: LONGINT;
737 BEGIN
738 FOR i := 0 TO 255 DO toUpper[i] := CHR(i); toLower[i] := CHR(i) END;
739 FOR i := ORD("A") TO ORD("Z") DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
740 FOR i := 0C0H TO 0D6H DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
741 FOR i := 0D8H TO 0DEH DO toLower[i] := CHR(i + 32); toUpper[i + 32] := CHR(i) END;
742 (* toUpper[ORD("ÿ")] := "Ÿ"; ISO 8859-1 has no this? *)
743 digits := "0123456789ABCDEF";
744 maxExp := SHORT(ENTIER(Math.Log(MAX(LONGREAL)))) + 1;
745 maxDig := SHORT(ENTIER(-Math.Log(Math.Eps())));
746 factor := Math.IntPower(10, maxDig)
747 END Init;
748
749 BEGIN
750 Init
751 END CPStrings.
Another attempt to make Oberon compiler
[15/08/2024 14:52:34]
DEADSOFTWARE 2012-2024