gcc/m2/gm2-libs-iso/LowReal.mod

   1 (* LowReal.mod implements ISO LowReal.def  Copyright (C) 2008-2024 Free Software Foundation, Inc.
   2
   3 Copyright (C) 2008-2024 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 LowReal ;
  28
  29 FROM SYSTEM IMPORT ADDRESS ;
  30 FROM Builtins IMPORT ilogb, modf, signbit, scalbn, huge_val, nextafter ;
  31 FROM dtoa IMPORT Mode, strtod, dtoa ;
  32 FROM libc IMPORT free ;
  33 FROM RealMath IMPORT power ;
  34 FROM ConvStringReal IMPORT RealToFloatString ;
  35 FROM StringConvert IMPORT ToSigFig ;
  36
  37 FROM EXCEPTIONS IMPORT ExceptionSource, AllocateSource, RAISE, CurrentNumber,
  38                        IsCurrentSource, IsExceptionalExecution ;
  39
  40 FROM DynamicStrings IMPORT String, InitString, KillString, Slice, Mark,
  41                            Mult, InitStringCharStar, Length, ConCat,
  42                            ConCatChar, InitStringChar, string ;
  43
  44 TYPE
  45    FloatingPointExceptions = (badparam) ;
  46
  47 VAR
  48    currentmode: Modes ;
  49
  50
  51 (*
  52    exponent - returns the exponent value of x
  53 *)
  54
  55 PROCEDURE exponent (x: REAL) : INTEGER ;
  56 BEGIN
  57    RETURN ilogb(x)
  58 END exponent ;
  59
  60
  61 (*
  62    fraction - returns the significand (or significant part) of x
  63 *)
  64
  65 PROCEDURE fraction (x: REAL) : REAL ;
  66 BEGIN
  67    RETURN scalbn (x, -ilogb (x))
  68 END fraction ;
  69
  70
  71 (*
  72    sign - returns the signum of x.  sign(x) = 1.0  for all x>0.0
  73           sign(x) = -1.0  for all x<0.0.
  74           may be either -1.0 or 1.0 if x = 0.0
  75 *)
  76
  77 PROCEDURE sign (x: REAL) : REAL ;
  78 BEGIN
  79    IF signbit(x)=0
  80    THEN
  81       RETURN 1.0
  82    ELSE
  83       RETURN -1.0
  84    END
  85 END sign ;
  86
  87
  88 (*
  89    succ - returns the next value of the type REAL greater than x
  90 *)
  91
  92 PROCEDURE succ (x: REAL) : REAL ;
  93 BEGIN
  94    RETURN nextafter(x, huge_val())
  95 END succ ;
  96
  97
  98 (*
  99    ulp - returns the value of a unit in the last place of x.
 100          So either:
 101
 102          ulp(x) = succ(x)-x     or
 103          ulp(x) = x-pred(x)     or both are true.
 104
 105          if the value does not exist then an exception is raised.
 106 *)
 107
 108 PROCEDURE ulp (x: REAL) : REAL ;
 109 BEGIN
 110    IF x<huge_val()
 111    THEN
 112       RETURN succ(x)-x
 113    ELSE
 114       RETURN x-pred(x)
 115    END
 116 END ulp ;
 117
 118
 119 (*
 120    pred - returns the previous value of the type REAL less than x.
 121 *)
 122
 123 PROCEDURE pred (x: REAL) : REAL ;
 124 BEGIN
 125    RETURN nextafter(x, -huge_val())
 126 END pred ;
 127
 128
 129 (*
 130    intpart - returns the integer part of x
 131 *)
 132
 133 PROCEDURE intpart (x: REAL) : REAL ;
 134 VAR
 135    y, z: REAL ;
 136 BEGIN
 137    z := modf(x, y) ;
 138    RETURN y
 139 END intpart ;
 140
 141
 142 (*
 143    fractpart - returns the fractional part of x
 144 *)
 145
 146 PROCEDURE fractpart (x: REAL) : REAL ;
 147 VAR
 148    y: REAL ;
 149 BEGIN
 150    RETURN modf(x, y)
 151 END fractpart ;
 152
 153
 154 (*
 155    scale - returns the value of x * radix ** n
 156
 157            The following holds true:
 158
 159            x = synthesize(exponent(x),fraction(x))
 160            x = scale(fraction(x), exponent(x))
 161 *)
 162
 163 PROCEDURE scale (x: REAL; n: INTEGER) : REAL ;
 164 BEGIN
 165    RETURN scalbn(x, n)
 166 END scale ;
 167
 168
 169 (*
 170    trunc - returns the value of the first n places of x.
 171 *)
 172
 173 PROCEDURE trunc (x: REAL; n: INTEGER) : REAL ;
 174 VAR
 175    y         : REAL ;
 176    sign,
 177    error     : BOOLEAN ;
 178    s         : String ;
 179    r         : ADDRESS ;
 180    point, l,
 181    powerOfTen: INTEGER ;
 182 BEGIN
 183    IF n<0
 184    THEN
 185       (* exception raised *)
 186       RAISE(except, ORD(badparam),
 187             'LowReal.trunc: cannot truncate to a negative number of digits') ;
 188       RETURN x
 189    ELSE
 190       r := dtoa(x, maxsignificant, 100, point, sign) ;
 191       s := InitStringCharStar(r) ;
 192       free(r) ;
 193       l := Length(s) ;
 194       IF VAL(INTEGER, n)<l
 195       THEN
 196          s := Slice(ToSigFig(s, n), 0, n)
 197       ELSE
 198          (* add '0's to make up significant figures *)
 199          s := ConCat(s, Mark(Mult(InitStringChar('0'), l-VAL(INTEGER, n))))
 200       END ;
 201       powerOfTen := point-1 ;
 202       point := 1 ;
 203
 204       IF (point<l) AND (point<VAL(INTEGER, n))
 205       THEN
 206          s := ConCat(ConCatChar(Slice(s, 0, point), '.'),
 207                      Slice(s, point, 0))
 208       END ;
 209       y := strtod(string(s), error) ;
 210       IF powerOfTen#0
 211       THEN
 212          y := power(y, FLOAT(powerOfTen))
 213       END ;
 214       s := KillString(s) ;
 215       RETURN y
 216    END
 217 END trunc ;
 218
 219
 220 (*
 221    round - returns the value of x rounded to the first n places.
 222            n significant figures.
 223 *)
 224
 225 PROCEDURE round (x: REAL; n: INTEGER) : REAL ;
 226 VAR
 227    y    : REAL ;
 228    error: BOOLEAN ;
 229    s    : String ;
 230 BEGIN
 231    IF n<0
 232    THEN
 233       (* exception raised *)
 234       RAISE(except, ORD(badparam),
 235             'LowReal.round: cannot round to a negative number of digits') ;
 236       RETURN x
 237    ELSE
 238       s := RealToFloatString(x, n) ;
 239       y := strtod(string(s), error) ;
 240       s := KillString(s) ;
 241       RETURN y
 242    END
 243 END round ;
 244
 245
 246 (*
 247    synthesize - returns a value of the type REAL constructed from
 248                 the given expart and frapart.
 249
 250                 The following holds true:
 251
 252                 x = synthesize(exponent(x),fraction(x))
 253                 x = scale(fraction(x), exponent(x))
 254 *)
 255
 256 PROCEDURE synthesize (expart: INTEGER; frapart: REAL) : REAL ;
 257 BEGIN
 258    RETURN scalbn(frapart, expart)
 259 END synthesize ;
 260
 261
 262 (*
 263    setMode - sets status flags appropriate to the underlying implementation
 264              of the type REAL.
 265 *)
 266
 267 PROCEDURE setMode (m: Modes) ;
 268 BEGIN
 269    currentmode := m
 270 END setMode ;
 271
 272
 273 (*
 274    currentMode - returns the current status flags in the form set by setMode
 275 *)
 276
 277 PROCEDURE currentMode () : Modes ;
 278 BEGIN
 279    RETURN currentmode
 280 END currentMode ;
 281
 282
 283 (*
 284    IsLowException - returns TRUE if the current coroutine is in the exceptional
 285                     execution state because of the raising of an exception in a
 286                     routine from this module; otherwise returns FALSE.
 287 *)
 288
 289 PROCEDURE IsLowException () : BOOLEAN ;
 290 BEGIN
 291    RETURN( IsExceptionalExecution() AND IsCurrentSource(except) )
 292 END IsLowException ;
 293
 294
 295 VAR
 296    except: ExceptionSource ;
 297 BEGIN
 298    AllocateSource(except)
 299 END LowReal.