summaryrefslogtreecommitdiff
path: root/src/grt/grt-values.adb
diff options
context:
space:
mode:
Diffstat (limited to 'src/grt/grt-values.adb')
-rw-r--r--src/grt/grt-values.adb639
1 files changed, 639 insertions, 0 deletions
diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb
new file mode 100644
index 0000000..3d703bc
--- /dev/null
+++ b/src/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;
generated by cgit (git 2.34.1) at 2024-12-20 12:09:54 +0000