path: root/gcc/m2/gm2-libs-iso/RealConv.mod

(* RealConv.mod implement the ISO RealConv specification.

Copyright (C) 2008-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE RealConv ;

FROM SYSTEM IMPORT ADDRESS ;
FROM ConvTypes IMPORT ScanClass ;
FROM CharClass IMPORT IsNumeric, IsWhiteSpace ;
FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, KillString, Length, Slice, Mark, Index, string ;
FROM dtoa IMPORT strtod ;
FROM ConvStringReal IMPORT RealToFloatString, RealToEngString, RealToFixedString ;
FROM M2RTS IMPORT Halt ;
FROM libc IMPORT free ;
IMPORT EXCEPTIONS ;


TYPE
   RealConvException = (noException, invalid, outofrange) ;

VAR
   realConv:  EXCEPTIONS.ExceptionSource ;


(* Low-level REAL/string conversions *)

(* Represents the start state of a finite state scanner for real
   numbers - assigns class of inputCh to chClass and a procedure
   representing the next state to nextState.
*)

PROCEDURE ScanReal (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                    VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanSecondDigit ;
      chClass := valid
   ELSIF (inputCh='+') OR (inputCh='-')
   THEN
      nextState := scanFirstDigit ;
      chClass := valid
   ELSIF IsWhiteSpace(inputCh)
   THEN
      nextState := ScanReal ;
      chClass := padding
   ELSE
      nextState := ScanReal ;
      chClass := invalid
   END
END ScanReal ;


(*
   scanFirstDigit - 
*)

PROCEDURE scanFirstDigit (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                          VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanSecondDigit ;
      chClass := valid
   ELSE
      nextState := scanFirstDigit ;
      chClass := invalid
   END
END scanFirstDigit ;


(*
   scanSecondDigit - 
*)

PROCEDURE scanSecondDigit (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                           VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanSecondDigit ;
      chClass := valid
   ELSIF inputCh='.'
   THEN
      nextState := scanFixed ;
      chClass := valid
   ELSIF inputCh='E'
   THEN
      nextState := scanScientific ;
      chClass := valid
   ELSE
      nextState := noOpFinished ;
      chClass := terminator
   END
END scanSecondDigit ;


(*
   scanFixed - 
*)

PROCEDURE scanFixed (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                     VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanFixed ;
      chClass := valid
   ELSIF inputCh='E'
   THEN
      nextState := scanScientific ;
      chClass := valid
   ELSE
      nextState := noOpFinished ;
      chClass := terminator
   END
END scanFixed ;


(*
   scanScientific - 
*)

PROCEDURE scanScientific (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                          VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanScientificSecond ;
      chClass := valid
   ELSIF (inputCh='-') OR (inputCh='+')
   THEN
      nextState := scanScientificSign ;
      chClass := valid
   ELSE
      nextState := scanScientific ;
      chClass := invalid
   END
END scanScientific ;


(*
   scanScientificSign - 
*)

PROCEDURE scanScientificSign (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                              VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanScientificSecond ;
      chClass := valid
   ELSE
      nextState := scanScientificSign ;
      chClass := invalid
   END
END scanScientificSign ;


(*
   scanScientificSecond - 
*)

PROCEDURE scanScientificSecond (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                                VAR nextState: ConvTypes.ScanState) ;
BEGIN
   IF IsNumeric(inputCh)
   THEN
      nextState := scanScientificSecond ;
      chClass := valid
   ELSE
      nextState := noOpFinished ;
      chClass := terminator
   END
END scanScientificSecond ;


(*
   noOpFinished - 
*)

PROCEDURE noOpFinished (inputCh: CHAR; VAR chClass: ConvTypes.ScanClass;
                        VAR nextState: ConvTypes.ScanState) ;
BEGIN
   nextState := noOpFinished ;
   chClass := terminator ;
   (* should we raise an exception here? *)
END noOpFinished ;


(* Returns the format of the string value for conversion to REAL. *)

PROCEDURE FormatReal (str: ARRAY OF CHAR) : ConvResults ;
VAR
   proc   : ConvTypes.ScanState ;
   chClass: ConvTypes.ScanClass ;
   i, h   : CARDINAL ;
BEGIN
   i := 1 ;
   h := LENGTH(str) ;
   ScanReal(str[0], chClass, proc) ;
   WHILE (i<h) AND (chClass=padding) DO
      proc(str[i], chClass, proc) ;
      INC(i)
   END ;
   IF chClass=terminator
   THEN
      RETURN( strEmpty )
   END ;
   WHILE (i<h) AND (chClass=valid) DO
      proc(str[i], chClass, proc) ;
      INC(i)
   END ;
   CASE chClass OF

   padding   :  RETURN( strWrongFormat ) |
   terminator,
   valid     :  RETURN( strAllRight ) |
   invalid   :  RETURN( strWrongFormat )

   END
END FormatReal ;


(* Returns the value corresponding to the real number string value
   str if str is well-formed; otherwise raises the RealConv
   exception.
*)

PROCEDURE ValueReal (str: ARRAY OF CHAR) : REAL ;
BEGIN
   IF FormatReal(str)=strAllRight
   THEN
      RETURN( doValueReal(str) )
   ELSE
      EXCEPTIONS.RAISE(realConv, ORD(invalid),
                       'RealConv.' + __FUNCTION__ + ': real number is invalid')
   END
END ValueReal ;


(*
   doValueReal - str, is a well-formed real number and its
                 value is returned.
*)

PROCEDURE doValueReal (str: ARRAY OF CHAR) : REAL ;
VAR
   r    : REAL ;
   error: BOOLEAN ;
   s    : String ;
BEGIN
   s := InitString(str) ;
   r := strtod(string(s), error) ;
   s := KillString(s) ;
   IF error
   THEN
      EXCEPTIONS.RAISE(realConv, ORD(outofrange),
                       'RealConv.' + __FUNCTION__ + ': real number is out of range')
   END ;
   RETURN( r )
END doValueReal ;


(* Returns the number of characters in the floating-point string
   representation of real with sigFigs significant figures.
*)

PROCEDURE LengthFloatReal (real: REAL; sigFigs: CARDINAL) : CARDINAL ;
VAR
   s: String ;
   l: CARDINAL ;
BEGIN
   s := RealToFloatString(real, sigFigs) ;
   l := Length(s) ;
   s := KillString(s) ;
   RETURN( l )
END LengthFloatReal ;


(* Returns the number of characters in the floating-point engineering
   string representation of real with sigFigs significant figures.
*)

PROCEDURE LengthEngReal (real: REAL; sigFigs: CARDINAL) : CARDINAL ;
VAR
   s: String ;
   l: CARDINAL ;
BEGIN
   s := RealToEngString(real, sigFigs) ;
   l := Length(s) ;
   s := KillString(s) ;
   RETURN( l )
END LengthEngReal ;


(* Returns the number of characters in the fixed-point string
   representation of real rounded to the given place relative to the
   decimal point.
*)

PROCEDURE LengthFixedReal (real: REAL; place: INTEGER) : CARDINAL ;
VAR
   s: String ;
   l: CARDINAL ;
BEGIN
   s := RealToFixedString(real, place) ;
   l := Length(s) ;
   s := KillString(s) ;
   RETURN( l )
END LengthFixedReal ;


(* Returns TRUE if the current coroutine is in the exceptional
   execution state because of the raising of an exception in a
   routine from this module; otherwise returns FALSE.
*)

PROCEDURE IsRConvException () : BOOLEAN ;
BEGIN
   RETURN( EXCEPTIONS.IsCurrentSource(realConv) )
END IsRConvException ;


BEGIN
   EXCEPTIONS.AllocateSource(realConv)
END RealConv.