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

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