diff options
Diffstat (limited to 'src/translate/grt/grt-values.adb')
| -rw-r--r-- | src/translate/grt/grt-values.adb | 639 |
1 files changed, 639 insertions, 0 deletions
diff --git a/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb new file mode 100644 index 0000000..3d703bc --- /dev/null +++ b/src/translate/grt/grt-values.adb @@ -0,0 +1,639 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL 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 2, or (at your option) any later +-- version. +-- +-- GHDL 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. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Utils; + +package body Grt.Values is + + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean is + begin + return C = ' ' or C = NBSP or C = HT; + end Is_Whitespace; + + -- Increase POS to skip leading whitespace characters, decrease LEN to + -- skip trailing whitespaces in string S. + procedure Remove_Whitespaces (S : Std_String_Basep; + Len : in out Ghdl_Index_Type; + Pos : in out Ghdl_Index_Type) is + begin + -- GHDL: allow several leading whitespace. + while Pos < Len loop + exit when not Is_Whitespace (S (Pos)); + Pos := Pos + 1; + end loop; + + -- GHDL: allow several leading whitespace. + while Len > Pos loop + exit when not Is_Whitespace (S (Len - 1)); + Len := Len - 1; + end loop; + if Pos = Len then + Error_E ("'value: empty string"); + end if; + end Remove_Whitespaces; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character is + begin + if C >= 'A' and then C <= 'Z' then + return Character'Val + (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); + else + return C; + end if; + end To_LC; + + -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF. + -- Comparaison is case insensitive, but REF must be lowercase (REF is + -- supposed to come from an RTI). + function String_Match (S : Std_String_Basep; + Pos : Ghdl_Index_Type; + Len : Ghdl_Index_Type; + Ref : Ghdl_C_String) return Boolean + is + P : Ghdl_Index_Type; + C : Character; + begin + P := 0; + loop + C := Ref (Natural (P + 1)); + if Pos + P = Len then + -- End of string. + return C = ASCII.NUL; + end if; + if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then + return False; + end if; + P := P + 1; + end loop; + end String_Match; + + -- Return the value of STR for enumerated type RTI. + function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + Remove_Whitespaces (S, Len, Pos); + + for I in 0 .. Enum_Rti.Nbr - 1 loop + if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then + return I; + end if; + end loop; + Error_C ("'value: '"); + Error_C_Std (S (Pos .. Len)); + Error_C ("' not in enumeration '"); + Error_C (Enum_Rti.Name); + Error_E ("'"); + end Ghdl_Value_Enum; + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1 + is + begin + return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_B1; + + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8 + is + begin + return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E8; + + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32 + is + begin + return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E32; + + -- Convert S (INIT_POS .. LEN) to a signed integer. + function Ghdl_Value_I64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_I64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Sep : Character; + Val, D, Base : Ghdl_I64; + Exp : Integer; + begin + C := S (Pos); + + -- Be user friendly. + -- FIXME: reference. + if C = '-' or C = '+' then + Error_E ("'value: leading sign +/- not allowed"); + end if; + + Val := 0; + 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 + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + 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 + return Val; + end if; + + if C = '#' or C = ':' then + Base := Val; + Val := 0; + Sep := C; + Pos := Pos + 1; + if Base < 2 or Base > 16 then + Error_E ("'value: bad base"); + end if; + if Pos >= Len then + Error_E ("'value: missing based integer"); + 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 => + Error_E ("'value: digit expected"); + end case; + if D >= Base then + Error_E ("'value: digit >= base"); + end if; + Val := Val * Base + D; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + C := S (Pos); + if C = '#' or C = ':' then + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + exit; + elsif C = '_' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after underscore"); + 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 + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '+' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after sign"); + end if; + C := S (Pos); + elsif C = '-' then + Error_E ("'value: negativ exponent not allowed"); + 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 + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + 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 + Error_E ("'value: trailing characters after blank"); + end if; + + return Val; + end Ghdl_Value_I64; + + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64 + is + 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. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_I64 (S, Len, Pos); + end Ghdl_Value_I64; + + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 + is + begin + 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 + 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; + 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; + + -- 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; + 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; + end if; + + return Val; + end Ghdl_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; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_F64 (S, Len, Pos); + end Ghdl_Value_F64; + + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type) + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Split between abstract literal (optionnal) and unit name. + Lit_End := Lit_Pos; + Is_Real := False; + while Lit_End < Len loop + exit when Is_Whitespace (S (Lit_End)); + if S (Lit_End) = '.' then + Is_Real := True; + end if; + Lit_End := Lit_End + 1; + end loop; + if Lit_End = Len then + -- No literal + Unit_Pos := Lit_Pos; + Lit_End := 0; + else + Unit_Pos := Lit_End + 1; + while Unit_Pos < Len loop + exit when not Is_Whitespace (S (Unit_Pos)); + Unit_Pos := Unit_Pos + 1; + end loop; + end if; + end Ghdl_Value_Physical_Split; + + function Ghdl_Value_Physical_Type (Str : Std_String_Ptr; + Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Unit_Pos : Ghdl_Index_Type; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + + Found_Real : Boolean; + + Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc := + To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Multiple : Ghdl_Rti_Access; + Mult : Ghdl_I64; + begin + -- Remove trailing whitespaces. FIXME: also called in physical_split. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Extract literal and unit + Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit value + Multiple := null; + for i in 0 .. Phys_Rti.Nbr - 1 loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i)); + if String_Match (S, Unit_Pos, Len, Unit_Name) then + Multiple := Phys_Rti.Units (i); + exit; + end if; + end loop; + if Multiple = null then + Error_C ("'value: unit '"); + Error_C_Std (S (Unit_Pos .. Len - 1)); + Error_C ("' not in physical type '"); + Error_C (Phys_Rti.Name); + Error_E ("'"); + end if; + + Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti); + + if Lit_End = 0 then + return Mult; + else + if Found_Real then + return Ghdl_I64 + (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); + else + return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult; + end if; + end if; + end Ghdl_Value_Physical_Type; + + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P64 then + Error_E ("Physical_Type_64'value: incorrect RTI"); + end if; + return Ghdl_Value_Physical_Type (Str, Rti); + end Ghdl_Value_P64; + + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P32 then + Error_E ("Physical_Type_32'value: incorrect RTI"); + end if; + return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti)); + end Ghdl_Value_P32; + +end Grt.Values; |