gcc/m2/gm2-libs/NumberIO.mod

   1 (* NumberIO.mod provides conversion of ordinal numbers.
   2
   3 Copyright (C) 2001-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE NumberIO ;
  28
  29
  30 FROM ASCII IMPORT nul ;
  31 FROM StrIO IMPORT ReadString, WriteString, WriteLn ;
  32 FROM StrLib IMPORT StrLen, StrRemoveWhitePrefix ;
  33
  34
  35 CONST
  36    MaxLineLength = 79 ;
  37    MaxDigits     = 20 ;
  38    MaxHexDigits  = 20 ;
  39    MaxOctDigits  = 40 ;
  40    MaxBits       = 64 ;
  41
  42
  43 PROCEDURE CardToStr (x, n: CARDINAL ; VAR a: ARRAY OF CHAR) ;
  44 VAR
  45    i, j,
  46    Higha : CARDINAL ;
  47    buf   : ARRAY [1..MaxDigits] OF CARDINAL ;
  48 BEGIN
  49    i := 0 ;
  50    REPEAT
  51       INC(i) ;
  52       IF i>MaxDigits
  53       THEN
  54          WriteString('NumberIO - increase MaxDigits') ; WriteLn ;
  55          HALT
  56       END ;
  57       buf[i] := x MOD 10 ;
  58       x := x DIV 10 ;
  59    UNTIL x=0 ;
  60    j := 0 ;
  61    Higha := HIGH(a) ;
  62    WHILE (n>i) AND (j<=Higha) DO
  63       a[j] := ' ' ;
  64       INC(j) ;
  65       DEC(n)
  66    END ;
  67    WHILE (i>0) AND (j<=Higha) DO
  68       a[j] := CHR( buf[i] + ORD('0') ) ;
  69       INC(j) ;
  70       DEC(i)
  71    END ;
  72    IF j<=Higha
  73    THEN
  74       a[j] := nul
  75    END
  76 END CardToStr ;
  77
  78
  79 PROCEDURE StrToCard (a: ARRAY OF CHAR ; VAR x: CARDINAL) ;
  80 VAR
  81    i     : CARDINAL ;
  82    ok    : BOOLEAN ;
  83    higha : CARDINAL ;
  84 BEGIN
  85    StrRemoveWhitePrefix(a, a) ;
  86    higha := StrLen(a) ;
  87    i := 0 ;
  88    ok := TRUE ;
  89    WHILE ok DO
  90       IF i<higha
  91       THEN
  92          IF (a[i]<'0') OR (a[i]>'9')
  93          THEN
  94             INC(i)
  95          ELSE
  96             ok := FALSE
  97          END
  98       ELSE
  99          ok := FALSE
 100       END
 101    END ;
 102    x := 0 ;
 103    IF i<higha
 104    THEN
 105       ok := TRUE ;
 106       REPEAT
 107          x := 10*x + (ORD(a[i])-ORD('0')) ;
 108          IF i<higha
 109          THEN
 110             INC(i) ;
 111             IF (a[i]<'0') OR (a[i]>'9')
 112             THEN
 113                ok := FALSE
 114             END
 115          ELSE
 116             ok := FALSE
 117          END
 118       UNTIL NOT ok ;
 119    END
 120 END StrToCard ;
 121
 122
 123 PROCEDURE IntToStr (x: INTEGER; n: CARDINAL ; VAR a: ARRAY OF CHAR) ;
 124 VAR
 125    i, j, c,
 126    Higha   : CARDINAL ;
 127    buf     : ARRAY [1..MaxDigits] OF CARDINAL ;
 128    Negative: BOOLEAN ;
 129 BEGIN
 130    IF x<0
 131    THEN
 132       Negative := TRUE ;
 133       c := VAL(CARDINAL, ABS(x+1))+1 ;
 134       IF n>0
 135       THEN
 136          DEC(n)
 137       END
 138    ELSE
 139       c := x ;
 140       Negative := FALSE
 141    END ;
 142    i := 0 ;
 143    REPEAT
 144       INC(i) ;
 145       IF i>MaxDigits
 146       THEN
 147          WriteString('NumberIO - increase MaxDigits') ; WriteLn ;
 148          HALT
 149       END ;
 150       buf[i] := c MOD 10 ;
 151       c := c DIV 10 ;
 152    UNTIL c=0 ;
 153    j := 0 ;
 154    Higha := HIGH(a) ;
 155    WHILE (n>i) AND (j<=Higha) DO
 156       a[j] := ' ' ;
 157       INC(j) ;
 158       DEC(n)
 159    END ;
 160    IF Negative
 161    THEN
 162       a[j] := '-' ;
 163       INC(j)
 164    END ;
 165    WHILE (i#0) AND (j<=Higha) DO
 166       a[j] := CHR( buf[i] + ORD('0') ) ;
 167       INC(j) ;
 168       DEC(i)
 169    END ;
 170    IF j<=Higha
 171    THEN
 172       a[j] := nul
 173    END
 174 END IntToStr ;
 175
 176
 177 PROCEDURE StrToInt (a: ARRAY OF CHAR ; VAR x: INTEGER) ;
 178 VAR
 179    i        : CARDINAL ;
 180    ok,
 181    Negative : BOOLEAN ;
 182    higha    : CARDINAL ;
 183 BEGIN
 184    StrRemoveWhitePrefix(a, a) ;
 185    higha := StrLen(a) ;
 186    i := 0 ;
 187    Negative := FALSE ;
 188    ok := TRUE ;
 189    WHILE ok DO
 190       IF i<higha
 191       THEN
 192          IF a[i]='-'
 193          THEN
 194             INC(i) ;
 195             Negative := NOT Negative
 196          ELSIF (a[i]<'0') OR (a[i]>'9')
 197          THEN
 198             INC(i)
 199          ELSE
 200             ok := FALSE
 201          END
 202       ELSE
 203          ok := FALSE
 204       END
 205    END ;
 206    x := 0 ;
 207    IF i<higha
 208    THEN
 209       ok := TRUE ;
 210       REPEAT
 211          IF Negative
 212          THEN
 213             x := 10*x - INTEGER(ORD(a[i])-ORD('0'))
 214          ELSE
 215             x := 10*x + INTEGER(ORD(a[i])-ORD('0'))
 216          END ;
 217          IF i<higha
 218          THEN
 219             INC(i) ;
 220             IF (a[i]<'0') OR (a[i]>'9')
 221             THEN
 222                ok := FALSE
 223             END
 224          ELSE
 225             ok := FALSE
 226          END
 227       UNTIL NOT ok ;
 228    END
 229 END StrToInt ;
 230
 231
 232 PROCEDURE HexToStr (x, n: CARDINAL ; VAR a: ARRAY OF CHAR) ;
 233 VAR
 234    i, j,
 235    Higha : CARDINAL ;
 236    buf   : ARRAY [1..MaxHexDigits] OF CARDINAL ;
 237 BEGIN
 238    i := 0 ;
 239    REPEAT
 240       INC(i) ;
 241       IF i>MaxHexDigits
 242       THEN
 243          WriteString('NumberIO - increase MaxDigits') ; WriteLn ;
 244          HALT
 245       END ;
 246       buf[i] := x MOD 010H ;
 247       x := x DIV 010H ;
 248    UNTIL x=0 ;
 249    j := 0 ;
 250    Higha := HIGH(a) ;
 251    WHILE (n>i) AND (j<=Higha) DO
 252       a[j] := '0' ;
 253       INC(j) ;
 254       DEC(n)
 255    END ;
 256    WHILE (i#0) AND (j<=Higha) DO
 257       IF buf[i]<10
 258       THEN
 259          a[j] := CHR( buf[i] + ORD('0') )
 260       ELSE
 261          a[j] := CHR( buf[i] + ORD('A')-10 )
 262       END ;
 263       INC(j) ;
 264       DEC(i)
 265    END ;
 266    IF j<=Higha
 267    THEN
 268       a[j] := nul
 269    END
 270 END HexToStr ;
 271
 272
 273 PROCEDURE StrToHex (a: ARRAY OF CHAR ; VAR x: CARDINAL) ;
 274 VAR
 275    i: INTEGER ;
 276 BEGIN
 277    StrToHexInt(a, i) ;
 278    x := VAL(CARDINAL, i)
 279 END StrToHex ;
 280
 281
 282 PROCEDURE StrToHexInt (a: ARRAY OF CHAR ; VAR x: INTEGER) ;
 283 VAR
 284    i     : CARDINAL ;
 285    ok    : BOOLEAN ;
 286    higha : CARDINAL ;
 287 BEGIN
 288    StrRemoveWhitePrefix(a, a) ;
 289    higha := StrLen(a) ;
 290    i := 0 ;
 291    ok := TRUE ;
 292    WHILE ok DO
 293       IF i<higha
 294       THEN
 295          IF ((a[i]>='0') AND (a[i]<='9')) OR ((a[i]>='A') AND (a[i]<='F'))
 296          THEN
 297             ok := FALSE
 298          ELSE
 299             INC(i)
 300          END
 301       ELSE
 302          ok := FALSE
 303       END
 304    END ;
 305    x := 0 ;
 306    IF i<higha
 307    THEN
 308       ok := TRUE ;
 309       REPEAT
 310          IF (a[i]>='0') AND (a[i]<='9')
 311          THEN
 312             x := 010H*x + VAL(INTEGER, (ORD(a[i])-ORD('0')))
 313          ELSIF (a[i]>='A') AND (a[i]<='F')
 314          THEN
 315             x := 010H*x + VAL(INTEGER, (ORD(a[i])-ORD('A')+10))
 316          END ;
 317          IF i<higha
 318          THEN
 319             INC(i) ;
 320             IF ((a[i]<'0') OR (a[i]>'9')) AND ((a[i]<'A') OR (a[i]>'F'))
 321             THEN
 322                ok := FALSE
 323             END
 324          ELSE
 325             ok := FALSE
 326          END
 327       UNTIL NOT ok ;
 328    END
 329 END StrToHexInt ;
 330
 331
 332 PROCEDURE OctToStr (x, n: CARDINAL ; VAR a: ARRAY OF CHAR) ;
 333 VAR
 334    i, j,
 335    Higha : CARDINAL ;
 336    buf   : ARRAY [1..MaxOctDigits] OF CARDINAL ;
 337 BEGIN
 338    i := 0 ;
 339    REPEAT
 340       INC(i) ;
 341       IF i>MaxOctDigits
 342       THEN
 343          WriteString('NumberIO - increase MaxDigits') ; WriteLn ;
 344          HALT
 345       END ;
 346       buf[i] := x MOD 8 ;
 347       x := x DIV 8 ;
 348    UNTIL x=0 ;
 349    j := 0 ;
 350    Higha := HIGH(a) ;
 351    WHILE (n>i) AND (j<=Higha) DO
 352       a[j] := ' ' ;
 353       INC(j) ;
 354       DEC(n)
 355    END ;
 356    WHILE (i>0) AND (j<=Higha) DO
 357       a[j] := CHR( buf[i] + ORD('0') ) ;
 358       INC(j) ;
 359       DEC(i)
 360    END ;
 361    IF j<=Higha
 362    THEN
 363       a[j] := nul
 364    END
 365 END OctToStr ;
 366
 367
 368 PROCEDURE StrToOct (a: ARRAY OF CHAR ; VAR x: CARDINAL) ;
 369 VAR
 370    i: INTEGER ;
 371 BEGIN
 372    StrToOctInt(a, i) ;
 373    x := VAL(CARDINAL, i)
 374 END StrToOct ;
 375
 376
 377 PROCEDURE StrToOctInt (a: ARRAY OF CHAR ; VAR x: INTEGER) ;
 378 VAR
 379    i     : CARDINAL ;
 380    ok    : BOOLEAN ;
 381    higha : CARDINAL ;
 382 BEGIN
 383    StrRemoveWhitePrefix(a, a) ;
 384    higha := StrLen(a) ;
 385    i := 0 ;
 386    ok := TRUE ;
 387    WHILE ok DO
 388       IF i<higha
 389       THEN
 390          IF (a[i]<'0') OR (a[i]>'7')
 391          THEN
 392             INC(i)
 393          ELSE
 394             ok := FALSE
 395          END
 396       ELSE
 397          ok := FALSE
 398       END
 399    END ;
 400    x := 0 ;
 401    IF i<higha
 402    THEN
 403       ok := TRUE ;
 404       REPEAT
 405          x := 8*x + VAL(INTEGER, (ORD(a[i])-ORD('0'))) ;
 406          IF i<higha
 407          THEN
 408             INC(i) ;
 409             IF (a[i]<'0') OR (a[i]>'7')
 410             THEN
 411                ok := FALSE
 412             END
 413          ELSE
 414             ok := FALSE
 415          END
 416       UNTIL NOT ok ;
 417    END
 418 END StrToOctInt ;
 419
 420
 421 PROCEDURE BinToStr (x, n: CARDINAL ; VAR a: ARRAY OF CHAR) ;
 422 VAR
 423    i, j,
 424    Higha : CARDINAL ;
 425    buf   : ARRAY [1..MaxBits] OF CARDINAL ;
 426 BEGIN
 427    i := 0 ;
 428    REPEAT
 429       INC(i) ;
 430       IF i>MaxBits
 431       THEN
 432          WriteString('NumberIO - increase MaxBits') ; WriteLn ;
 433          HALT
 434       END ;
 435       buf[i] := x MOD 2 ;
 436       x := x DIV 2 ;
 437    UNTIL x=0 ;
 438    j := 0 ;
 439    Higha := HIGH(a) ;
 440    WHILE (n>i) AND (j<=Higha) DO
 441       a[j] := ' ' ;
 442       INC(j) ;
 443       DEC(n)
 444    END ;
 445    WHILE (i>0) AND (j<=Higha) DO
 446       a[j] := CHR( buf[i] + ORD('0') ) ;
 447       INC(j) ;
 448       DEC(i)
 449    END ;
 450    IF j<=Higha
 451    THEN
 452       a[j] := nul
 453    END
 454 END BinToStr ;
 455
 456
 457 PROCEDURE StrToBin (a: ARRAY OF CHAR ; VAR x: CARDINAL) ;
 458 VAR
 459    i: INTEGER ;
 460 BEGIN
 461    StrToBinInt(a, i) ;
 462    x := VAL(CARDINAL, i)
 463 END StrToBin ;
 464
 465
 466 PROCEDURE StrToBinInt (a: ARRAY OF CHAR ; VAR x: INTEGER) ;
 467 VAR
 468    i     : CARDINAL ;
 469    ok    : BOOLEAN ;
 470    higha : CARDINAL ;
 471 BEGIN
 472    StrRemoveWhitePrefix(a, a) ;
 473    higha := StrLen(a) ;
 474    i := 0 ;
 475    ok := TRUE ;
 476    WHILE ok DO
 477       IF i<higha
 478       THEN
 479          IF (a[i]<'0') OR (a[i]>'1')
 480          THEN
 481             INC(i)
 482          ELSE
 483             ok := FALSE
 484          END
 485       ELSE
 486          ok := FALSE
 487       END
 488    END ;
 489    x := 0 ;
 490    IF i<higha
 491    THEN
 492       ok := TRUE ;
 493       REPEAT
 494          x := 2*x + VAL(INTEGER, (ORD(a[i])-ORD('0'))) ;
 495          IF i<higha
 496          THEN
 497             INC(i) ;
 498             IF (a[i]<'0') OR (a[i]>'1')
 499             THEN
 500                ok := FALSE
 501             END
 502          ELSE
 503             ok := FALSE
 504          END
 505       UNTIL NOT ok ;
 506    END
 507 END StrToBinInt ;
 508
 509
 510 PROCEDURE ReadOct (VAR x: CARDINAL) ;
 511 VAR
 512    a : ARRAY [0..MaxLineLength] OF CHAR ;
 513 BEGIN
 514    ReadString( a ) ;
 515    StrToOct( a, x )
 516 END ReadOct ;
 517
 518
 519 PROCEDURE WriteOct (x, n: CARDINAL) ;
 520 VAR
 521    a : ARRAY [0..MaxLineLength] OF CHAR ;
 522 BEGIN
 523    OctToStr( x, n, a ) ;
 524    WriteString( a )
 525 END WriteOct ;
 526
 527
 528 PROCEDURE ReadBin (VAR x: CARDINAL) ;
 529 VAR
 530    a : ARRAY [0..MaxLineLength] OF CHAR ;
 531 BEGIN
 532    ReadString(a) ;
 533    StrToBin(a, x)
 534 END ReadBin ;
 535
 536
 537 PROCEDURE WriteBin (x, n: CARDINAL) ;
 538 VAR
 539    a : ARRAY [0..MaxLineLength] OF CHAR ;
 540 BEGIN
 541    BinToStr( x, n, a ) ;
 542    WriteString( a )
 543 END WriteBin ;
 544
 545
 546 PROCEDURE ReadCard (VAR x: CARDINAL) ;
 547 VAR
 548    a : ARRAY [0..MaxLineLength] OF CHAR ;
 549 BEGIN
 550    ReadString( a ) ;
 551    StrToCard( a, x )
 552 END ReadCard ;
 553
 554
 555 PROCEDURE WriteCard (x, n: CARDINAL) ;
 556 VAR
 557    a : ARRAY [0..MaxLineLength] OF CHAR ;
 558 BEGIN
 559    CardToStr( x, n, a ) ;
 560    WriteString( a )
 561 END WriteCard ;
 562
 563
 564 PROCEDURE ReadInt (VAR x: INTEGER) ;
 565 VAR
 566    a : ARRAY [0..MaxLineLength] OF CHAR ;
 567 BEGIN
 568    ReadString( a ) ;
 569    StrToInt( a, x )
 570 END ReadInt ;
 571
 572
 573 PROCEDURE WriteInt (x: INTEGER; n: CARDINAL) ;
 574 VAR
 575    a : ARRAY [0..MaxLineLength] OF CHAR ;
 576 BEGIN
 577    IntToStr( x, n, a ) ;
 578    WriteString( a )
 579 END WriteInt ;
 580
 581
 582 PROCEDURE ReadHex (VAR x: CARDINAL) ;
 583 VAR
 584    a : ARRAY [0..MaxLineLength] OF CHAR ;
 585 BEGIN
 586    ReadString( a ) ;
 587    StrToHex( a, x )
 588 END ReadHex ;
 589
 590
 591 PROCEDURE WriteHex (x, n: CARDINAL) ;
 592 VAR
 593    a : ARRAY [0..MaxLineLength] OF CHAR ;
 594 BEGIN
 595    HexToStr( x, n, a ) ;
 596    WriteString( a )
 597 END WriteHex ;
 598
 599
 600 END NumberIO.