gcc/m2/gm2-libs-iso/RealConv.mod - gcc.git - Git at Google

 (* RealConv.mod implement the ISO RealConv specification.

 Copyright (C) 2008-2025 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') ;
       RETURN 0.0
    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.
	(* RealConv.mod implement the ISO RealConv specification.

	Copyright (C) 2008-2025 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') ;
	RETURN 0.0
	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.