vhdl: refactoring - remove trans_be, mainly added to vhdl-back_end

1 files changed, 169 insertions, 0 deletions

diff --git a/src/vhdl/vhdl-back_end.adb b/src/vhdl/vhdl-back_end.adb
new file mode 100644
index 000000000..1a0449ec0
--- /dev/null
+++ b/src/vhdl/vhdl-back_end.adb
@@ -0,0 +1,169 @@
+--  Back-end specialization
+--  Copyright (C) 2023 Tristan Gingold
+--
+--  This program 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 of the License, or
+--  (at your option) any later version.
+--
+--  This program 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 this program.  If not, see <gnu.org/licenses>.
+
+with Types; use Types;
+with Str_Table;
+with Std_Names;
+
+with Vhdl.Errors; use Vhdl.Errors;
+with Vhdl.Sem_Specs;
+
+package body Vhdl.Back_End is
+   function Get_String_As_String (Expr : Iir) return String is
+   begin
+      case Get_Kind (Expr) is
+         when Iir_Kind_String_Literal8 =>
+            declare
+               Len : constant Natural := Natural (Get_String_Length (Expr));
+               Id : constant String8_Id := Get_String8_Id (Expr);
+               Res : String (1 .. Len);
+            begin
+               for I in 1 .. Len loop
+                  Res (I) := Str_Table.Char_String8 (Id, Pos32 (I));
+               end loop;
+               return Res;
+            end;
+         when Iir_Kind_Simple_Aggregate =>
+            declare
+               List : constant Iir_Flist := Get_Simple_Aggregate_List (Expr);
+               Len : constant Natural := Get_Nbr_Elements (List);
+               Res : String (1 .. Len);
+               El : Iir;
+            begin
+               for I in Flist_First .. Flist_Last (List) loop
+                  El := Get_Nth_Element (List, I);
+                  pragma Assert (Get_Kind (El) = Iir_Kind_Enumeration_Literal);
+                  Res (I - Flist_First + 1) :=
+                    Character'Val (Get_Enum_Pos (El));
+               end loop;
+               return Res;
+            end;
+         when others =>
+            if Get_Expr_Staticness (Expr) /= Locally then
+               Error_Msg_Sem
+                 (+Expr, "value of FOREIGN attribute must be locally static");
+               return "";
+            else
+               raise Internal_Error;
+            end if;
+      end case;
+   end Get_String_As_String;
+
+   function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type
+   is
+      --  Look for 'FOREIGN.
+      Attr : constant Iir_Attribute_Value :=
+        Vhdl.Sem_Specs.Find_Attribute_Value (Decl, Std_Names.Name_Foreign);
+      pragma Assert (Attr /= Null_Iir);
+      Spec : constant Iir_Attribute_Specification :=
+        Get_Attribute_Specification (Attr);
+      Name : constant String := Get_String_As_String (Get_Expression (Spec));
+      Length : constant Natural := Name'Length;
+   begin
+      if Length = 0 then
+         return Foreign_Bad;
+      end if;
+
+      pragma Assert (Name'First = 1);
+
+      --  Only 'VHPIDIRECT' is recognized.
+      if Length >= 10 and then Name (1 .. 10) = "VHPIDIRECT" then
+         declare
+            Info : Foreign_Info_Type (Foreign_Vhpidirect);
+            P : Natural;
+            Sf, Sl : Natural;
+            Lf, Ll : Natural;
+         begin
+            P := 11;
+
+            --  Skip spaces.
+            while P <= Length and then Name (P) = ' ' loop
+               P := P + 1;
+            end loop;
+            if P > Length then
+               Error_Msg_Sem
+                 (+Spec, "missing subprogram/library name after VHPIDIRECT");
+               Info.Lib_Len := 0;
+               Info.Subprg_Len := 0;
+               return Info;
+            end if;
+            --  Extract library.
+            Lf := P;
+            while P <= Length and then Name (P) /= ' ' loop
+               P := P + 1;
+            end loop;
+            Ll := P - 1;
+            --  Extract subprogram.
+            while P <= Length and then Name (P) = ' ' loop
+               P := P + 1;
+            end loop;
+            Sf := P;
+            while P <= Length and then Name (P) /= ' ' loop
+               P := P + 1;
+            end loop;
+            Sl := P - 1;
+            if P <= Length then
+               Error_Msg_Sem (+Spec, "garbage at end of VHPIDIRECT");
+            end if;
+
+            --  Accept empty library.
+            if Sf > Length then
+               Sf := Lf;
+               Sl := Ll;
+               Lf := 1;
+               Ll := 0;
+            end if;
+
+            Info.Lib_Len := Ll - Lf + 1;
+            Info.Lib_Name (1 .. Info.Lib_Len) := Name (Lf .. Ll);
+
+            Info.Subprg_Len := Sl - Sf + 1;
+            Info.Subprg_Name (1 .. Info.Subprg_Len) := Name (Sf .. Sl);
+            return Info;
+         end;
+      elsif Length = 14
+        and then Name (1 .. 14) = "GHDL intrinsic"
+      then
+         return Foreign_Info_Type'(Kind => Foreign_Intrinsic);
+      else
+         Error_Msg_Sem
+           (+Spec,
+            "value of 'FOREIGN attribute does not begin with VHPIDIRECT");
+         return Foreign_Bad;
+      end if;
+   end Translate_Foreign_Id;
+
+   procedure Sem_Foreign_Wrapper (Decl : Iir)
+   is
+      Fi : Foreign_Info_Type;
+   begin
+      case Get_Kind (Decl) is
+         when Iir_Kind_Architecture_Body =>
+            Error_Msg_Sem (+Decl, "FOREIGN architectures are not yet handled");
+         when Iir_Kind_Procedure_Declaration
+           | Iir_Kind_Function_Declaration =>
+            null;
+         when others =>
+            Error_Kind ("sem_foreign", Decl);
+      end case;
+      --  Let it generate error messages.
+      Fi := Translate_Foreign_Id (Decl);
+
+      if Sem_Foreign_Hook /= null then
+         Sem_Foreign_Hook.all (Decl, Fi);
+      end if;
+   end Sem_Foreign_Wrapper;
+end Vhdl.Back_End;