libs/cpascal/RealStr.cp

   1 MODULE RealStr;
   2 (*
   3  * Purpose:
   4  *   Provides REAL/string conversions
   5  *
   6  * Log:
   7  *   April 96  jl  initial version
   8  *
   9  * Notes:
  10  *   Complies with ISO/IEC 10514-1:1996  (as RealStr)
  11  *
  12  * Modified for Component Pascal by kjg, February 2004
  13  *
  14  *)
  15
  16   IMPORT RTS;
  17
  18 (***************************************************************)
  19 (*                                                             *)
  20 (*                   PRIVATE - NOT EXPORTED                    *)
  21 (*                                                             *)
  22 (***************************************************************)
  23
  24   CONST
  25      err = 9999;
  26
  27   TYPE
  28      CharPtr  = POINTER TO ARRAY OF CHAR;
  29      DigArray = ARRAY 28 OF CHAR;
  30
  31   (*===============================================================*)
  32
  33   PROCEDURE Message(OUT str : ARRAY OF CHAR; IN mss : ARRAY OF CHAR);
  34     VAR idx : INTEGER;
  35   BEGIN
  36     idx := 0;
  37     WHILE (idx < LEN(str)) & (idx < LEN(mss)) DO
  38       str[idx] := mss[idx]; INC(idx);
  39     END;
  40     IF idx < LEN(str) THEN str[idx] := 0X END;
  41   END Message;
  42
  43   (*===============================================================*)
  44
  45   PROCEDURE expLen(exp : INTEGER) : INTEGER;
  46   BEGIN
  47     exp := ABS(exp);
  48     IF    exp < 10  THEN RETURN 3;
  49     ELSIF exp < 100 THEN RETURN 4;
  50     ELSE  RETURN 5;
  51     END;
  52   END expLen;
  53
  54   (*===============================================================*)
  55
  56   PROCEDURE  CopyCh(ch : CHAR;
  57                 VAR ix : INTEGER;
  58                 VAR st : ARRAY OF CHAR);
  59   BEGIN
  60     IF ix < LEN(st) THEN st[ix] := ch; INC(ix) END;
  61   END CopyCh;
  62
  63   (*===============================================================*)
  64
  65   PROCEDURE CopyExp(ex : INTEGER;
  66                 VAR ix : INTEGER;
  67                 VAR st : ARRAY OF CHAR);
  68     VAR abX, val, len, idx, dHi : INTEGER;
  69   BEGIN
  70     dHi := LEN(st) - 1;
  71     len := expLen(ex);
  72     IF ix + len > dHi THEN ix := dHi - len END;
  73     IF ix < 2 THEN
  74       FOR idx := 0 TO MIN(ix+len, dHi-1) DO st[idx] := "*"; ix := idx+1 END;
  75     ELSE
  76       CopyCh("E",ix,st);
  77       IF ex > 0 THEN CopyCh("+",ix,st) ELSE CopyCh("-",ix,st) END;
  78       abX := ABS(ex); val := abX;
  79       IF abX >= 100 THEN
  80         CopyCh(CHR(val DIV 100 + ORD("0")),ix,st);
  81         val := val MOD 100;
  82       END;
  83       IF abX >= 10 THEN
  84         CopyCh(CHR(val DIV 10 + ORD("0")),ix,st);
  85       END;
  86       CopyCh(CHR(val MOD 10 + ORD("0")),ix,st);
  87     END;
  88   END CopyExp;
  89
  90   (*===============================================================*)
  91
  92   PROCEDURE GetDigits(real   : REAL;
  93                   OUT digits : DigArray;
  94                   OUT dPoint : INTEGER;
  95                   OUT isNeg  : BOOLEAN);
  96     VAR rIdx : INTEGER;      (* the read index   *)
  97         wIdx : INTEGER;      (* the write index  *)
  98         iLen : INTEGER;      (* integer part len *)
  99         eVal : INTEGER;      (* exponent value   *)
 100         buff : DigArray;     (* temporary buffer *)
 101         eNeg : BOOLEAN;      (* exponent is neg. *)
 102         rChr : CHAR;         (* last read char   *)
 103   BEGIN
 104    (*
 105     *  We want to assert that digit[0] # "0",
 106     *  unless real = zero. So to avoid a sack o'woe
 107     *)
 108     IF real = 0.0 THEN
 109       digits := "0";
 110       dPoint := 1;
 111       isNeg  := FALSE; RETURN;      (* PREEMPTIVE RETURN HERE *)
 112     END;
 113
 114     RTS.RealToStrInvar(real, buff);
 115     rIdx := 0;
 116     wIdx := 0;
 117     eVal := 0;
 118    (* get optional sign *)
 119     isNeg := (buff[0] = "-");
 120     IF isNeg THEN INC(rIdx) END;
 121
 122     rChr := buff[rIdx]; INC(rIdx);
 123     WHILE rChr = "0" DO
 124       rChr := buff[rIdx]; INC(rIdx);
 125     END;
 126
 127    (* get integer part *)
 128     WHILE (rChr <= "9") & (rChr >= "0") DO
 129       digits[wIdx] := rChr; INC(wIdx);
 130       rChr := buff[rIdx];   INC(rIdx);
 131     END;
 132     iLen := wIdx;              (* integer part ended  *)
 133
 134     IF rChr = "." THEN         (* get fractional part *)
 135       rChr := buff[rIdx];   INC(rIdx);
 136       IF wIdx = 0 THEN
 137        (* count any leading zeros *)
 138         WHILE rChr = "0" DO
 139           rChr := buff[rIdx]; INC(rIdx); DEC(iLen);
 140         END;
 141       END;
 142
 143       WHILE (rChr <= "9") & (rChr >= "0") DO
 144         digits[wIdx] := rChr; INC(wIdx);
 145         rChr := buff[rIdx];   INC(rIdx);
 146       END;
 147     END;
 148     digits[wIdx] := 0X;        (* terminate char arr. *)
 149
 150     IF (rChr = "E") OR (rChr = "e") THEN
 151                                (* get fractional part *)
 152       rChr := buff[rIdx];   INC(rIdx);
 153       IF rChr = "-" THEN
 154         eNeg := TRUE;
 155         rChr := buff[rIdx]; INC(rIdx);
 156       ELSE
 157         eNeg := FALSE;
 158         IF rChr = "+" THEN rChr := buff[rIdx]; INC(rIdx) END;
 159       END;
 160       WHILE (rChr <= "9") & (rChr >= "0") DO
 161         eVal := eVal * 10;
 162         INC(eVal, (ORD(rChr) - ORD("0")));
 163         rChr := buff[rIdx]; INC(rIdx);
 164       END;
 165       IF eNeg THEN eVal := -eVal END;
 166     END;
 167
 168    (* At this point, if we are not ended, we have a NaN *)
 169     IF rChr # 0X THEN
 170       digits := buff; dPoint := err;
 171     ELSE
 172      (* Index of virtual decimal point is eVal + iLen *)
 173       DEC(eVal);
 174       dPoint := iLen + eVal;
 175     END;
 176   END GetDigits;
 177
 178 (***************************************************************)
 179
 180   PROCEDURE RoundRelative(VAR str : DigArray;
 181                           VAR exp : INTEGER;
 182                               num : INTEGER);
 183     VAR len : INTEGER;
 184         idx : INTEGER;
 185         chr : CHAR;
 186   BEGIN
 187     len := LEN(str$);   (* we want num+1 digits *)
 188     IF num < 0 THEN
 189       str[0] := 0X;
 190     ELSIF num = 0 THEN
 191       chr := str[0];
 192       IF chr > "4" THEN
 193         str := "1"; INC(exp);
 194       ELSE
 195         str[num] := 0X;
 196       END;
 197     ELSIF num < len THEN
 198       chr := str[num];
 199       IF chr > "4" THEN (* round up str[num-1]  *)
 200         idx := num-1;
 201         LOOP
 202           str[idx] := CHR(ORD(str[idx]) + 1);
 203           IF str[idx] <= "9" THEN EXIT;
 204           ELSE
 205             str[idx] := "0"; (* and propagate *)
 206             IF idx = 0 THEN  (* need a shift  *)
 207               FOR idx := num TO 0 BY -1 DO str[idx+1] := str[idx] END;
 208               str[0] := "1"; INC(exp); EXIT;
 209             END;
 210           END;
 211           DEC(idx);
 212         END;
 213       END;
 214       str[num] := 0X;
 215     END;
 216   END RoundRelative;
 217
 218 (***************************************************************)
 219 (*                                                             *)
 220 (*                     PUBLIC - EXPORTED                       *)
 221 (*                                                             *)
 222 (***************************************************************)
 223
 224  (*===============================================================*
 225   *
 226   * Ignores any leading spaces in str. If the subsequent characters in str
 227   * are in the format of a signed real number, assigns a corresponding value
 228   * to real.  Assigns a value indicating the format of str to res.
 229   *)
 230   PROCEDURE StrToReal*(str  : ARRAY OF CHAR;
 231                    OUT real : REAL;
 232                    OUT res  : BOOLEAN);
 233
 234     VAR clrStr : RTS.NativeString;
 235   BEGIN
 236     clrStr := MKSTR(str);
 237     RTS.StrToRealInvar(clrStr, real, res);
 238   END StrToReal;
 239
 240  (*===============================================================*
 241   *
 242   * Converts the value of real to floating-point string form, with sigFigs
 243   * significant digits, and copies the possibly truncated result to str.
 244   *)
 245   PROCEDURE RealToFloat*(real    : REAL;
 246                          sigFigs : INTEGER;
 247                      OUT str     : ARRAY OF CHAR);
 248
 249     VAR len, fWid, index, ix : INTEGER;
 250         dExp   : INTEGER; (* decimal exponent *)
 251         neg    : BOOLEAN;
 252         digits : DigArray;
 253   BEGIN
 254     GetDigits(real, digits, dExp, neg);
 255     IF dExp = err THEN Message(str, digits); RETURN END;
 256     RoundRelative(digits, dExp, sigFigs);
 257
 258     index := 0;
 259     IF neg THEN CopyCh("-", index, str) END;
 260     fWid := LEN(digits$);
 261     IF fWid = 0 THEN  (* result is 0 *)
 262       CopyCh("0", index, str);
 263       dExp := 0;
 264     ELSE
 265       CopyCh(digits[0], index, str);
 266     END;
 267     IF sigFigs > 1 THEN
 268       CopyCh(".",index,str);
 269       IF fWid > 1 THEN
 270         FOR ix := 1  TO fWid - 1    DO CopyCh(digits[ix], index, str) END;
 271       END;
 272       FOR ix := fWid TO sigFigs - 1 DO CopyCh("0", index, str) END;
 273     END;
 274 (*
 275  *  IF dExp # 0 THEN CopyExp(dExp,index,str) END;
 276  *)
 277     CopyExp(dExp,index,str);
 278     IF index <= LEN(str)-1 THEN str[index] := 0X END;
 279   END RealToFloat;
 280
 281  (*===============================================================*
 282   *
 283   * Converts the value of real to floating-point string form, with sigFigs
 284   * significant digits, and copies the possibly truncated result to str.
 285   * The number is scaled with one to three digits in the whole number part and
 286   * with an exponent that is a multiple of three.
 287   *)
 288   PROCEDURE RealToEng*(real    : REAL;
 289                        sigFigs : INTEGER;
 290                    OUT str     : ARRAY OF CHAR);
 291     VAR len, index, ix : INTEGER;
 292         dExp   : INTEGER; (* decimal exponent *)
 293         fact   : INTEGER;
 294         neg    : BOOLEAN;
 295         digits : DigArray;
 296   BEGIN
 297     GetDigits(real, digits, dExp, neg);
 298     IF dExp = err THEN Message(str, digits); RETURN END;
 299     RoundRelative(digits, dExp, sigFigs);
 300
 301     len := LEN(digits$); INC(dExp);
 302     IF len = 0 THEN dExp := 1 END;  (* result = 0 *)
 303     fact := ((dExp - 1) MOD 3) + 1;
 304     DEC(dExp,fact);     (* make exponent multiple of three *)
 305
 306     index := 0;
 307     IF neg THEN CopyCh("-",index,str) END;
 308     IF fact <= len THEN
 309       FOR ix := 0   TO fact - 1 DO CopyCh(digits[ix],index,str) END;
 310     ELSE
 311       IF len > 0 THEN
 312         FOR ix := 0 TO len  - 1 DO CopyCh(digits[ix],index,str) END;
 313       END;
 314       FOR ix := len TO fact - 1 DO CopyCh("0",index,str) END;
 315     END;
 316     IF fact < sigFigs THEN
 317       CopyCh(".",index,str);
 318       IF fact < len THEN
 319         FOR ix := fact TO len - 1 DO CopyCh(digits[ix],index,str) END;
 320       ELSE
 321         len := fact;
 322       END;
 323       FOR ix := len TO sigFigs - 1 DO CopyCh("0",index,str) END;
 324     END;
 325 (*
 326  *  IF dExp # 0 THEN CopyExp(dExp,index,str) END;
 327  *)
 328     CopyExp(dExp,index,str);
 329     IF index <= LEN(str)-1 THEN str[index] := 0X END;
 330   END RealToEng;
 331
 332  (*===============================================================*
 333   *
 334   * Converts the value of real to fixed-point string form, rounded to the
 335   * given place relative to the decimal point, and copies the result to str.
 336   *)
 337   PROCEDURE RealToFixed*(real  : REAL;
 338                          place : INTEGER; (* requested no of frac. places *)
 339                      OUT str   : ARRAY OF CHAR);
 340     VAR lWid   : INTEGER;     (* Leading digit-str width  *)
 341         fWid   : INTEGER;     (* Width of fractional part *)
 342         tWid   : INTEGER;     (* Total width of str-rep.  *)
 343         zWid   : INTEGER;     (* Leading zeros in frac.   *)
 344         len    : INTEGER;     (* Significant digit length *)
 345         dExp   : INTEGER;     (* Pos. of rad. in dig-arr. *)
 346         dLen   : INTEGER;     (* Length of dest. array    *)
 347
 348         index  : INTEGER;
 349         ix     : INTEGER;
 350         neg    : BOOLEAN;
 351         radix  : BOOLEAN;
 352         digits : DigArray;
 353   BEGIN
 354    (* the decimal point and fraction part *)
 355    (* ["-"] "0" "." d^(fWid)       -- if dExp < 0 *)
 356    (* ["-"] d^(lWid) "." d^(fWid)  -- if fWid > 0 *)
 357    (* ["-"] d^(lWid)               -- if fWid = 0 *)
 358
 359     tWid := 0;
 360     dLen := LEN(str);
 361     IF place >= 0 THEN fWid := place ELSE fWid := 0 END;
 362     radix := (fWid > 0);
 363
 364     GetDigits(real, digits, dExp, neg);
 365     IF dExp = err THEN Message(str, digits); RETURN END;
 366
 367     RoundRelative(digits, dExp, place+dExp+1); (* this can change dExp! *)
 368
 369     (* Semantics of dExp value    *)
 370     (*  012345 ...  digit index   *)
 371     (*  dddddd ...  digit content *)
 372     (*    ^-------- dExp value    *)
 373     (* "ddd.ddd..." result str.   *)
 374
 375     len := LEN(digits$);
 376     IF len = 0 THEN neg := FALSE END; (* don't print "-0" *)
 377     IF dExp >= 0 THEN lWid := dExp+1 ELSE lWid := 1 END;
 378
 379     IF neg   THEN INC(tWid) END;
 380     IF radix THEN INC(tWid) END;
 381     INC(tWid, lWid);
 382     INC(tWid, fWid);
 383
 384     IF tWid > dLen THEN tWid := dLen END;
 385
 386     index := 0;
 387    (*
 388     *  Now copy the optional signe
 389     *)
 390     IF neg THEN CopyCh("-",index,str) END;
 391    (*
 392     *  Now copy the integer part
 393     *)
 394     IF dExp < 0 THEN
 395       CopyCh("0",index,str);
 396     ELSE
 397       IF lWid <= len THEN
 398         FOR ix := 0   TO lWid - 1 DO CopyCh(digits[ix],index,str) END;
 399       ELSE
 400         IF len > 0 THEN
 401           FOR ix := 0 TO len - 1  DO CopyCh(digits[ix],index,str) END;
 402         END;
 403         FOR ix := len TO lWid - 1 DO CopyCh("0",index,str) END;
 404       END;
 405     END;
 406    (*
 407     *  Now copy the fractional part
 408     *)
 409     IF radix THEN
 410       CopyCh(".",index,str);
 411       IF dExp < 0 THEN
 412        (*   012345 ...  digit idx  *)
 413        (*   dddddd ...  digit str. *)
 414        (*  ^-------- dExp = -1     *)
 415         zWid := MIN(-dExp-1, fWid); (* leading zero width *)
 416         FOR ix := 0 TO zWid - 1 DO CopyCh("0",index,str) END;
 417         FOR ix := 0 TO len - 1  DO CopyCh(digits[ix],index,str) END;
 418       ELSIF lWid < len THEN
 419         FOR ix := lWid TO len - 1 DO CopyCh(digits[ix],index,str) END;
 420       END;
 421       WHILE index < tWid DO CopyCh("0",index,str) END;
 422     END;
 423     IF index <= dLen-1 THEN str[index] := 0X END;
 424   END RealToFixed;
 425
 426  (*===============================================================*
 427   *
 428   * Converts the value of real as RealToFixed if the sign and magnitude can be
 429   * shown within the capacity of str, or otherwise as RealToFloat, and copies
 430   * the possibly truncated result to str.
 431   * The number of places or significant digits are implementation-defined.
 432   *)
 433   PROCEDURE RealToStr*(real: REAL; OUT str: ARRAY OF CHAR);
 434   BEGIN
 435     RTS.RealToStrInvar(real, str);
 436   RESCUE (x);
 437     RealToFloat(real, 16, str);
 438   END RealToStr;
 439
 440 (* ---------------------------------------- *)
 441
 442 END RealStr.