diff options
| -rw-r--r-- | ortho/gcc/lang.opt | 4 | ||||
| -rw-r--r-- | sem_names.adb | 50 | ||||
| -rw-r--r-- | translate/gcc/Make-lang.in | 2 | ||||
| -rw-r--r-- | translate/grt/grt-values.adb | 188 | ||||
| -rw-r--r-- | translate/grt/grt-values.ads | 19 |
5 files changed, 231 insertions, 32 deletions
diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt index 2636885..5acffdb 100644 --- a/ortho/gcc/lang.opt +++ b/ortho/gcc/lang.opt @@ -22,8 +22,8 @@ vhdl Joined Set the directory of the work library P -vhdl Joined --P<dir> Add <dir> to the end of the vhdl library path +vhdl JoinedOrMissing +;-P<dir> Add <dir> to the end of the vhdl library path -elab vhdl Separate diff --git a/sem_names.adb b/sem_names.adb index 6c1c378..9b33a58 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -1449,19 +1449,52 @@ package body Sem_Names is is Prot_Type : Iir; Method : Iir; + Found : Boolean := False; begin Prot_Type := Get_Type (Sub_Name); - Method := Find_Name_In_Chain - (Get_Declaration_Chain (Prot_Type), Suffix); - if Method = Null_Iir then + +-- bld 26 apr 2013 : the following returned the FIRST method matching name +-- rather than the full overload list. +-- Method := Find_Name_In_Chain +-- (Get_Declaration_Chain (Prot_Type), Suffix); +-- if Method = Null_Iir then +-- Error_Msg_Sem +-- ("no method " & Name_Table.Image (Suffix) & " in " +-- & Disp_Node (Prot_Type), Name); +-- return; +-- else +-- Add_Result (Res, Method); +-- end if; + + -- build overload list from all declarations in chain, matching name, + -- which are actually functions or procedures. + -- TODO: error here if there's a variable with matching name? + -- currently we warn... + -- rather than add a "Find_nth_name_in chain" to iirs_utils I have + -- expanded the chain walk here. + Method := Get_Declaration_Chain (Prot_Type); + while Method /= Null_Iir loop + if Get_Identifier (Method) = Suffix then -- found the name + -- check it's a method! + case Get_Kind (Method) is + when Iir_Kind_Function_Declaration | + Iir_Kind_Procedure_Declaration => + Found := True; + Add_Result (Res, Method); + when others => + Warning_Msg_Sem ("sem_as_method_call", Method); + end case; + end if; + Method := Get_Chain (Method); + end loop; + if not Found then Error_Msg_Sem ("no method " & Name_Table.Image (Suffix) & " in " & Disp_Node (Prot_Type), Name); return; - else - Add_Result (Res, Method); end if; +-- following is handled by later stages -- case Get_Kind (Method) is -- when Iir_Kind_Function_Declaration => -- Call := Create_Iir (Iir_Kind_Function_Call); @@ -1958,8 +1991,8 @@ package body Sem_Names is end; if Res = Null_Iir then Error_Msg_Sem - ("prefix is neither a function name " - & "nor can it be sliced or indexed", Name); + ("No overloaded subprogram found matching " + & Disp_Node(Prefix_Name), Name); end if; when Iir_Kinds_Function_Declaration => Add_Result (Res, Sem_As_Function_Call (Prefix_Name, @@ -2033,6 +2066,9 @@ package body Sem_Names is when Iir_Kind_Psl_Declaration => Res := Sem_Psl.Sem_Psl_Name (Name); + when Iir_Kind_Design_Unit => + Error_Msg_Sem ("function name is a design unit", Name); + when others => Error_Kind ("sem_parenthesis_name", Prefix); end case; diff --git a/translate/gcc/Make-lang.in b/translate/gcc/Make-lang.in index 3c6e5c3..9c74b4e 100644 --- a/translate/gcc/Make-lang.in +++ b/translate/gcc/Make-lang.in @@ -171,6 +171,8 @@ vhdl.generated-manpages: vhdl.install-normal: +vhdl.install-plugin: + # Install the driver program as ghdl. vhdl.install-common: ghdl$(exeext) -mkdir $(DESTDIR)$(bindir) diff --git a/translate/grt/grt-values.adb b/translate/grt/grt-values.adb index 404a2a4..c60c667 100644 --- a/translate/grt/grt-values.adb +++ b/translate/grt/grt-values.adb @@ -22,6 +22,135 @@ package body Grt.Values is NBSP : constant Character := Character'Val (160); HT : constant Character := Character'Val (9); + procedure Remove_Whitespace(S : in Std_String_Basep; + Pos : in out Ghdl_Index_Type; + Len : in Ghdl_Index_Type; + Chars : out Ghdl_B2) is + begin + Chars := False; + -- GHDL: allow several leading whitespace. + while Pos < Len loop + case S (Pos) is + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + when others => + Chars := True; + exit; + end case; + end loop; + end Remove_Whitespace; + + procedure Stub_Error(S : String) is + begin + Error_E ("'value: function Ghdl_Value_" & S & " is a stub!" + & "Please report as missing to http://gna.org/projects/ghdl"); + end Stub_Error; + + function 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 LC; + + procedure Make_LC_String(S : Std_String_Basep; + Pos : in out Ghdl_Index_Type; + Len : Ghdl_Index_Type; + Str : out String) is + pragma unreferenced(Len); + begin + for i in Str'range loop + Str(i) := LC(S(Pos)); -- LC it later + Pos := Pos + 1; + end loop; + end Make_LC_String; + + function StringMatch(Str : String; EnumStr : Ghdl_C_String) return boolean + is + EnumLen : constant Natural := strlen(EnumStr); + begin + for j in Str'range loop + if j > EnumLen or else Str(j) /= EnumStr(j) then + return false; + end if; + end loop; + if Str'last = EnumLen then + return true; + else + return false; + end if; + end StringMatch; + + function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + Val : Ghdl_Index_Type := 0; + S : constant Std_String_Basep := Str.Base; + Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + Chars : Ghdl_B2; + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + + begin + Remove_Whitespace(S, Pos, Len, Chars); + if Pos = Len then + Error_E ("'value: empty string"); + end if; + + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + + declare + Str : String(1..Natural(Len - Pos)); + Found : Boolean := False; + begin + Make_LC_String(S, Pos, Len, Str); + for i in 0 .. Enum_Rti.Nbr - 1 loop + if StringMatch(Str, Enum_Rti.Names.all(i)) then + Found := True; + Val := i; + exit; + end if; + end loop; + if not Found then + Error_E ("'value: " & Str & " not in enumeration " & + Enum_Rti.Name.all(1..strlen(Enum_Rti.Name))); + end if; + end; + + Remove_Whitespace(S, Pos, Len, Chars); + if Chars then + Error_E ("'value: trailing characters after blank"); + end if; + -- Stub_Error("E8"); + return Val; + end Ghdl_Value_Enum; + + function Ghdl_Value_B2 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B2 + is + begin + return Ghdl_B2'Val(Ghdl_Value_Enum (Str , Rti )); + end Ghdl_Value_B2; + + 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; + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 is S : constant Std_String_Basep := Str.Base; @@ -31,22 +160,13 @@ package body Grt.Values is Sep : Character; Val, D, Base : Ghdl_I32; Exp : Integer; + Chars : Ghdl_B2; begin -- LRM 14.1 -- Leading [and trailing] whitespace is allowed and ignored. -- -- GHDL: allow several leading whitespace. - while Pos < Len loop - case S (Pos) is - when ' ' - | NBSP - | HT => - Pos := Pos + 1; - when others => - exit; - end case; - end loop; - + Remove_Whitespace(S, Pos, Len, Chars); if Pos = Len then Error_E ("'value: empty string"); end if; @@ -197,19 +317,43 @@ package body Grt.Values is -- LRM 14.1 -- [Leading] and trailing whitespace is allowed and ignored. -- - -- GHDL: allow several leading whitespace. - while Pos < Len loop - case S (Pos) is - when ' ' - | NBSP - | HT => - Pos := Pos + 1; - when others => - Error_E ("'value: trailing characters after blank"); - end case; - end loop; + -- GHDL: allow several trailing whitespace. + Remove_Whitespace(S, Pos, Len, Chars); + if Chars then + Error_E ("'value: trailing characters after blank"); + end if; return Val; end Ghdl_Value_I32; + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 is + pragma unreferenced(Str); + Val : constant Ghdl_F64 := 0.0; + begin + Stub_Error("F64"); + return Val; + end Ghdl_Value_F64; + + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + pragma unreferenced(Str); + pragma unreferenced(Rti); + Val : constant Ghdl_I64 := 0; + begin + Stub_Error("P64"); + return Val; + end Ghdl_Value_P64; + + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32 + is + pragma unreferenced(Str); + pragma unreferenced(Rti); + Val : constant Ghdl_I32 := 0; + begin + Stub_Error("P32"); + return Val; + end Ghdl_Value_P32; + end Grt.Values; diff --git a/translate/grt/grt-values.ads b/translate/grt/grt-values.ads index 25bde5a..2bf51a4 100644 --- a/translate/grt/grt-values.ads +++ b/translate/grt/grt-values.ads @@ -16,10 +16,27 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Grt.Types; use Grt.Types; --- with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis; use Grt.Rtis; package Grt.Values is + function Ghdl_Value_B2 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B2; + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8; + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32; function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32; + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64; + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64; + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32; private + pragma Export (Ada, Ghdl_Value_B2, "__ghdl_value_b2"); + pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8"); + pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32"); pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32"); + pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64"); + pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64"); + pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32"); end Grt.Values; |