diff options
Diffstat (limited to 'src/grt/grt-values.adb')
-rw-r--r-- | src/grt/grt-values.adb | 402 |
1 files changed, 36 insertions, 366 deletions
diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb index 404fec43c..7a2f09ed5 100644 --- a/src/grt/grt-values.adb +++ b/src/grt/grt-values.adb @@ -23,12 +23,9 @@ with Grt.Errors; use Grt.Errors; with Grt.Rtis_Utils; with Grt.Strings; use Grt.Strings; +with Grt.To_Strings; use Grt.To_Strings; package body Grt.Values is - - NBSP : constant Character := Character'Val (160); - HT : constant Character := Character'Val (9); - -- Increase POS to skip leading whitespace characters, decrease LEN to -- skip trailing whitespaces in string S. procedure Remove_Whitespaces (S : Std_String_Basep; @@ -134,189 +131,28 @@ package body Grt.Values is return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti)); end Ghdl_Value_E32; - -- Convert S (INIT_POS .. LEN) to a signed integer. - function Value_I64 (S : Std_String_Basep; - Len : Ghdl_Index_Type; - Init_Pos : Ghdl_Index_Type) return Value_I64_Result - is - Pos : Ghdl_Index_Type := Init_Pos; - C : Character; - Sep : Character; - Val, D, Base : Ghdl_I64; - Exp : Integer; - Is_Neg : Boolean; - begin - C := S (Pos); - Val := 0; - - -- LRM02 14.1 Predefined attributes - -- Restrictions: It is an error is the parameter is not a valid string - -- representation of a literal ot type T. - -- - -- Apparently there is no definition of 'string representation', the - -- closest is: - -- - -- LRM02 14.3 Package TEXTIO - -- The representation of both INTEGER and REAL values [...] - Is_Neg := False; - if C = '+' or C = '-' then - if Pos = Len then - return (Status => Value_Err_No_Digit, Pos => Pos); - end if; - Pos := Pos + 1; - Is_Neg := C = '-'; - C := S (Pos); - end if; - - loop - if C in '0' .. '9' then - Val := Val * 10 - (Character'Pos (C) - Character'Pos ('0')); - Pos := Pos + 1; - exit when Pos >= Len; - C := S (Pos); - else - return (Status => Value_Err_No_Digit, Pos => Pos); - end if; - case C is - when '_' => - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_Underscore, Pos => Pos); - end if; - C := S (Pos); - when '#' - | ':' - | 'E' - | 'e' => - exit; - when ' ' - | NBSP - | HT => - Pos := Pos + 1; - exit; - when others => - null; - end case; - end loop; - - if Pos >= Len then - if not Is_Neg then - Val := -Val; - end if; - return (Status => Value_Ok, Val => Val); - end if; - - if C = '#' or C = ':' then - Base := -Val; - Val := 0; - Sep := C; - Pos := Pos + 1; - if Base < 2 or Base > 16 then - return (Status => Value_Err_Bad_Base, Pos => Pos); - end if; - if Pos >= Len then - return (Status => Value_Err_No_Digit, Pos => Pos); - end if; - C := S (Pos); - loop - case C is - when '0' .. '9' => - D := Character'Pos (C) - Character'Pos ('0'); - when 'a' .. 'f' => - D := Character'Pos (C) - Character'Pos ('a') + 10; - when 'A' .. 'F' => - D := Character'Pos (C) - Character'Pos ('A') + 10; - when others => - return (Status => Value_Err_Bad_Digit, Pos => Pos); - end case; - if D >= Base then - return (Status => Value_Err_Bad_Digit, Pos => Pos); - end if; - Val := Val * Base - D; - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_Bad_End_Sign, Pos => Pos); - end if; - C := S (Pos); - if C = '#' or C = ':' then - if C /= Sep then - return (Status => Value_Err_Bad_End_Sign, Pos => Pos); - end if; - Pos := Pos + 1; - exit; - elsif C = '_' then - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_Underscore, Pos => Pos); - end if; - C := S (Pos); - end if; - end loop; - else - Base := 10; - end if; - - -- Handle exponent. - if C = 'e' or C = 'E' then - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_No_Digit, Pos => Pos); - end if; - C := S (Pos); - if C = '+' then - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_No_Digit, Pos => Pos); - end if; - C := S (Pos); - elsif C = '-' then - return (Status => Value_Err_Bad_Exponent, Pos => Pos); - end if; - Exp := 0; - loop - if C in '0' .. '9' then - Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0'); - Pos := Pos + 1; - exit when Pos >= Len; - C := S (Pos); - else - return (Status => Value_Err_Bad_Digit, Pos => Pos); - end if; - case C is - when '_' => - Pos := Pos + 1; - if Pos >= Len then - return (Status => Value_Err_Underscore, Pos => Pos); - end if; - C := S (Pos); - when ' ' - | NBSP - | HT => - Pos := Pos + 1; - exit; - when others => - null; - end case; - end loop; - while Exp > 0 loop - if Exp mod 2 = 1 then - Val := Val * Base; - end if; - Exp := Exp / 2; - Base := Base * Base; - end loop; - end if; - - if Pos /= Len then - return (Status => Value_Err_Trailing_Chars, Pos => Pos); - end if; - - if not Is_Neg then - Val := -Val; - end if; + procedure Value_Error (Status : Value_Status_Error); + pragma No_Return (Value_Error); - return (Status => Value_Ok, Val => Val); - end Value_I64; + procedure Value_Error (Status : Value_Status_Error) is + begin + case Status is + when Value_Err_No_Digit => + Error_E ("'value: missing digit"); + when Value_Err_Underscore => + Error_E ("'value: incorrect underscore"); + when Value_Err_Bad_Base => + Error_E ("'value: bad base"); + when Value_Err_Bad_Digit => + Error_E ("'value: digit expected"); + when Value_Err_Bad_End_Sign => + Error_E ("'value: incorrect or missing sign number"); + when Value_Err_Bad_Exponent => + Error_E ("'value: negativ exponent not allowed"); + when Value_Err_Trailing_Chars => + Error_E ("'value: trailing characters after blank"); + end case; + end Value_Error; function Value_I64 (S : Std_String_Basep; Len : Ghdl_Index_Type; Init_Pos : Ghdl_Index_Type) @@ -366,194 +202,28 @@ package body Grt.Values is return Ghdl_I32 (Ghdl_Value_I64 (Str)); end Ghdl_Value_I32; - -- From patch attached to https://gna.org/bugs/index.php?18352 - -- thanks to Christophe Curis https://gna.org/users/lobotomy - function Ghdl_Value_F64 (S : Std_String_Basep; - Len : Ghdl_Index_Type; - Init_Pos : Ghdl_Index_Type) - return Ghdl_F64 + function Value_F64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) return Ghdl_F64 is - Pos : Ghdl_Index_Type := Init_Pos; - C : Character; - Is_Negative, Is_Neg_Exp : Boolean := False; - Base : Ghdl_F64; - Intg : Ghdl_I32; - Val, Df : Ghdl_F64; - Sep : Character; - FrcExp : Ghdl_F64; + Res : Value_F64_Result; begin - C := S (Pos); - if C = '-' then - Is_Negative := True; - Pos := Pos + 1; - elsif C = '+' then - Pos := Pos + 1; - end if; - - if Pos >= Len then - Error_E ("'value: decimal digit expected"); - end if; - - -- Read Integer-or-Base part (may be optional) - Intg := 0; - while Pos < Len loop - C := S (Pos); - if C in '0' .. '9' then - Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); - elsif C /= '_' then - exit; - end if; - Pos := Pos + 1; - end loop; - - if Pos = Len then - return Ghdl_F64 (Intg); - end if; - - -- Special case: base was specified - if C = '#' or C = ':' then - if Intg < 2 or Intg > 16 then - Error_E ("'value: bad base"); - end if; - Base := Ghdl_F64 (Intg); - Val := 0.0; - Sep := C; - Pos := Pos + 1; - if Pos >= Len then - Error_E ("'value: missing based decimal"); - end if; + Res := Value_F64 (S, Len, Init_Pos); - -- Get the Integer part of the Value - while Pos < Len loop - C := S (Pos); - case C is - when '0' .. '9' => - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') ); - when 'A' .. 'F' => - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); - when 'a' .. 'f' => - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); - when others => - exit; - end case; - if C /= '_' then - if Df >= Base then - Error_E ("'value: digit greater than base"); - end if; - Val := Val * Base + Df; - end if; - Pos := Pos + 1; - end loop; - if Pos >= Len then - Error_E ("'value: missing end sign number"); - end if; + if Res.Status = Value_Ok then + return Res.Val; else - Base := 10.0; - Sep := ' '; - Val := Ghdl_F64 (Intg); - end if; - - -- Handle the Fractional part - if C = '.' then - Pos := Pos + 1; - FrcExp := 1.0; - while Pos < Len loop - C := S (Pos); - case C is - when '0' .. '9' => - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0')); - when 'A' .. 'F' => - exit when Sep = ' '; - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); - when 'a' .. 'f' => - exit when Sep = ' '; - Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); - when others => - exit; - end case; - if C /= '_' then - FrcExp := FrcExp / Base; - if Df > Base then - Error_E ("'value: digit greater than base"); - end if; - Val := Val + Df * FrcExp; - end if; - Pos := Pos + 1; - end loop; - end if; - - -- If base was specified, we must find here the end marker - if Sep /= ' ' then - if Pos >= Len then - Error_E ("'value: missing end sign number"); - end if; - if C /= Sep then - Error_E ("'value: sign number mismatch"); - end if; - Pos := Pos + 1; - end if; - - -- Handle exponent - if Pos < Len then - C := S (Pos); - if C = 'e' or C = 'E' then - Pos := Pos + 1; - if Pos >= Len then - Error_E ("'value: no character after exponent"); - end if; - C := S (Pos); - if C = '-' then - Is_Neg_Exp := True; - Pos := Pos + 1; - elsif C = '+' then - Pos := Pos + 1; - end if; - Intg := 0; - while Pos < Len loop - C := S (Pos); - if C in '0' .. '9' then - Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); - else - exit; - end if; - Pos := Pos + 1; - end loop; - -- This Exponentiation method is sub-optimal, - -- but it does not depend on any library - FrcExp := 1.0; - if Is_Neg_Exp then - while Intg > 0 loop - FrcExp := FrcExp / 10.0; - Intg := Intg - 1; - end loop; - else - while Intg > 0 loop - FrcExp := FrcExp * 10.0; - Intg := Intg - 1; - end loop; - end if; - Val := Val * FrcExp; - end if; - end if; - - if Pos /= Len then - Error_E ("'value: trailing characters after blank"); - end if; - - if Is_Negative then - Val := -Val; + Value_Error (Res.Status); end if; - - return Val; - end Ghdl_Value_F64; + end Value_F64; -- From patch attached to https://gna.org/bugs/index.php?18352 -- thanks to Christophe Curis https://gna.org/users/lobotomy function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 is - S : constant Std_String_Basep := Str.Base; - Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; - Pos : Ghdl_Index_Type := 0; + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; begin -- LRM 14.1 -- Leading and trailing whitespace is allowed and ignored. @@ -561,7 +231,7 @@ package body Grt.Values is -- GHDL: allow several leading whitespace. Remove_Whitespaces (S, Len, Pos); - return Ghdl_Value_F64 (S, Len, Pos); + return Value_F64 (S, Len, Pos); end Ghdl_Value_F64; procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; @@ -651,7 +321,7 @@ package body Grt.Values is else if Found_Real then return Ghdl_I64 - (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); + (Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); else return Value_I64 (S, Lit_End, Lit_Pos) * Mult; end if; |