OSVVM patch

5 files changed, 231 insertions, 32 deletions

diff --git a/ortho/gcc/lang.opt b/ortho/gcc/lang.opt
index 263688594..5acffdbaf 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 6c1c37872..9b33a5808 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 3c6e5c3a5..9c74b4e92 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 404a2a42e..c60c66738 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 25bde5abf..2bf51a479 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;