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

   1 (* ShortConv.mod implement the ISO ShortConv specification.
   2
   3 Copyright (C) 2009-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 ShortConv ;
  28
  29 FROM SYSTEM IMPORT ADDRESS ;
  30 FROM ConvTypes IMPORT ScanClass ;
  31 FROM CharClass IMPORT IsNumeric, IsWhiteSpace ;
  32 FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, KillString, Length, Slice, Mark, Index, string ;
  33 FROM dtoa IMPORT strtod ;
  34 FROM ConvStringShort IMPORT RealToFloatString, RealToEngString, RealToFixedString ;
  35 FROM M2RTS IMPORT Halt ;
  36 FROM libc IMPORT free ;
  37 IMPORT EXCEPTIONS ;
  38
  39
  40 TYPE
  41    RealConvException = (noException, invalid, outofrange) ;
  42
  43 VAR
  44    realConv: EXCEPTIONS.ExceptionSource ;
  45
  46
  47 (* Low-level LONGREAL/string conversions.  *)
  48
  49 (* Represents the start state of a finite state scanner for real
  50    numbers - assigns class of inputCh to chClass and a procedure
  51    representing the next state to nextState.
  52 *)
  53
  54 PROCEDURE ScanReal (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
  55                     VAR nextState: ConvTypes.ScanState) ;
  56 BEGIN
  57    IF IsNumeric(inputCh)
  58    THEN
  59       nextState := scanSecondDigit ;
  60       chClass := valid
  61    ELSIF (inputCh='+') OR (inputCh='-')
  62    THEN
  63       nextState := scanFirstDigit ;
  64       chClass := valid
  65    ELSIF IsWhiteSpace(inputCh)
  66    THEN
  67       nextState := ScanReal ;
  68       chClass := padding
  69    ELSE
  70       nextState := ScanReal ;
  71       chClass := invalid
  72    END
  73 END ScanReal ;
  74
  75
  76 (*
  77    scanFirstDigit -
  78 *)
  79
  80 PROCEDURE scanFirstDigit (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
  81                           VAR nextState: ConvTypes.ScanState) ;
  82 BEGIN
  83    IF IsNumeric(inputCh)
  84    THEN
  85       nextState := scanSecondDigit ;
  86       chClass := valid
  87    ELSE
  88       nextState := scanFirstDigit ;
  89       chClass := invalid
  90    END
  91 END scanFirstDigit ;
  92
  93
  94 (*
  95    scanSecondDigit -
  96 *)
  97
  98 PROCEDURE scanSecondDigit (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
  99                            VAR nextState: ConvTypes.ScanState) ;
 100 BEGIN
 101    IF IsNumeric(inputCh)
 102    THEN
 103       nextState := scanSecondDigit ;
 104       chClass := valid
 105    ELSIF inputCh='.'
 106    THEN
 107       nextState := scanFixed ;
 108       chClass := valid
 109    ELSIF inputCh='E'
 110    THEN
 111       nextState := scanScientific ;
 112       chClass := valid
 113    ELSE
 114       nextState := noOpFinished ;
 115       chClass := terminator
 116    END
 117 END scanSecondDigit ;
 118
 119
 120 (*
 121    scanFixed -
 122 *)
 123
 124 PROCEDURE scanFixed (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
 125                      VAR nextState: ConvTypes.ScanState) ;
 126 BEGIN
 127    IF IsNumeric(inputCh)
 128    THEN
 129       nextState := scanFixed ;
 130       chClass := valid
 131    ELSIF inputCh='E'
 132    THEN
 133       nextState := scanScientific ;
 134       chClass := valid
 135    ELSE
 136       nextState := noOpFinished ;
 137       chClass := terminator
 138    END
 139 END scanFixed ;
 140
 141
 142 (*
 143    scanScientific -
 144 *)
 145
 146 PROCEDURE scanScientific (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
 147                           VAR nextState: ConvTypes.ScanState) ;
 148 BEGIN
 149    IF IsNumeric(inputCh)
 150    THEN
 151       nextState := scanScientificSecond ;
 152       chClass := valid
 153    ELSIF (inputCh='-') OR (inputCh='+')
 154    THEN
 155       nextState := scanScientificSign ;
 156       chClass := valid
 157    ELSE
 158       nextState := scanScientific ;
 159       chClass := invalid
 160    END
 161 END scanScientific ;
 162
 163
 164 (*
 165    scanScientificSign -
 166 *)
 167
 168 PROCEDURE scanScientificSign (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
 169                               VAR nextState: ConvTypes.ScanState) ;
 170 BEGIN
 171    IF IsNumeric(inputCh)
 172    THEN
 173       nextState := scanScientificSecond ;
 174       chClass := valid
 175    ELSE
 176       nextState := scanScientificSign ;
 177       chClass := invalid
 178    END
 179 END scanScientificSign ;
 180
 181
 182 (*
 183    scanScientificSecond -
 184 *)
 185
 186 PROCEDURE scanScientificSecond (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
 187                                 VAR nextState: ConvTypes.ScanState) ;
 188 BEGIN
 189    IF IsNumeric(inputCh)
 190    THEN
 191       nextState := scanScientificSecond ;
 192       chClass := valid
 193    ELSE
 194       nextState := noOpFinished ;
 195       chClass := terminator
 196    END
 197 END scanScientificSecond ;
 198
 199
 200 (*
 201    noOpFinished -
 202 *)
 203
 204 PROCEDURE noOpFinished (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
 205                         VAR nextState: ConvTypes.ScanState) ;
 206 BEGIN
 207    nextState := noOpFinished ;
 208    chClass := terminator ;
 209    (* should we raise an exception here? *)
 210 END noOpFinished ;
 211
 212
 213 (* Returns the format of the string value for conversion to LONGREAL. *)
 214
 215 PROCEDURE FormatReal (str: ARRAY OF CHAR) : ConvResults ;
 216 VAR
 217    proc   : ConvTypes.ScanState ;
 218    chClass: ConvTypes.ScanClass ;
 219    i, h   : CARDINAL ;
 220 BEGIN
 221    i := 1 ;
 222    h := LENGTH(str) ;
 223    ScanReal(str[0], chClass, proc) ;
 224    WHILE (i<h) AND (chClass=padding) DO
 225       proc(str[i], chClass, proc) ;
 226       INC(i)
 227    END ;
 228
 229    IF chClass=terminator
 230    THEN
 231       RETURN( strEmpty )
 232    END ;
 233    WHILE (i<h) AND (chClass=valid) DO
 234       proc(str[i], chClass, proc) ;
 235       INC(i)
 236    END ;
 237    CASE chClass OF
 238
 239    padding   :  RETURN( strWrongFormat ) |
 240    terminator,
 241    valid     :  RETURN( strAllRight ) |
 242    invalid   :  RETURN( strWrongFormat )
 243
 244    END
 245 END FormatReal ;
 246
 247
 248 (* Returns the value corresponding to the real number string value
 249    str if str is well-formed; otherwise raises the RealConv
 250    exception.
 251 *)
 252
 253 PROCEDURE ValueReal (str: ARRAY OF CHAR) : SHORTREAL ;
 254 BEGIN
 255    IF FormatReal(str)=strAllRight
 256    THEN
 257       RETURN( doValueReal(str) )
 258    ELSE
 259       EXCEPTIONS.RAISE(realConv, ORD(invalid),
 260                        'ShortConv.' + __FUNCTION__ + ': real number is invalid')
 261    END
 262 END ValueReal ;
 263
 264
 265 (*
 266    doValueReal - str, is a well-formed real number and its
 267                  value is returned.
 268 *)
 269
 270 PROCEDURE doValueReal (str: ARRAY OF CHAR) : SHORTREAL ;
 271 VAR
 272    r    : SHORTREAL ;
 273    error: BOOLEAN ;
 274    s    : String ;
 275 BEGIN
 276    s := InitString(str) ;
 277    r := strtod (string(s), error) ;
 278    s := KillString(s) ;
 279    IF error
 280    THEN
 281       EXCEPTIONS.RAISE (realConv, ORD(outofrange),
 282                         'ShortConv.' + __FUNCTION__ + ': real number is out of range')
 283    END ;
 284    RETURN r
 285 END doValueReal ;
 286
 287
 288 (* Returns the number of characters in the floating-point string
 289    representation of real with sigFigs significant figures.
 290 *)
 291
 292 PROCEDURE LengthFloatReal (real: SHORTREAL; sigFigs: CARDINAL) : CARDINAL ;
 293 VAR
 294    s: String ;
 295    l: CARDINAL ;
 296 BEGIN
 297    s := RealToFloatString (real, sigFigs) ;
 298    l := Length (s) ;
 299    s := KillString (s) ;
 300    RETURN l
 301 END LengthFloatReal ;
 302
 303
 304 (* Returns the number of characters in the floating-point engineering
 305    string representation of real with sigFigs significant figures.
 306 *)
 307
 308 PROCEDURE LengthEngReal (real: SHORTREAL; sigFigs: CARDINAL) : CARDINAL ;
 309 VAR
 310    s: String ;
 311    l: CARDINAL ;
 312 BEGIN
 313    s := RealToEngString (real, sigFigs) ;
 314    l := Length (s) ;
 315    s := KillString (s) ;
 316    RETURN l
 317 END LengthEngReal ;
 318
 319
 320 (* Returns the number of characters in the fixed-point string
 321    representation of real rounded to the given place relative to the
 322    decimal point.
 323 *)
 324
 325 PROCEDURE LengthFixedReal (real: SHORTREAL; place: INTEGER) : CARDINAL ;
 326 VAR
 327    s: String ;
 328    l: CARDINAL ;
 329 BEGIN
 330    s := RealToFixedString (real, place) ;
 331    l := Length (s) ;
 332    s := KillString (s) ;
 333    RETURN l
 334 END LengthFixedReal ;
 335
 336
 337 (* Returns TRUE if the current coroutine is in the exceptional
 338    execution state because of the raising of an exception in a
 339    routine from this module; otherwise returns FALSE.
 340 *)
 341
 342 PROCEDURE IsRConvException () : BOOLEAN ;
 343 BEGIN
 344    RETURN( EXCEPTIONS.IsCurrentSource(realConv) )
 345 END IsRConvException ;
 346
 347
 348 BEGIN
 349    EXCEPTIONS.AllocateSource (realConv)
 350 END ShortConv.