New file.
authorArnaud Charlet <charlet@adacore.com>
Tue, 25 Apr 2017 08:25:29 +0000 (08:25 +0000)
committerArnaud Charlet <charlet@gcc.gnu.org>
Tue, 25 Apr 2017 08:25:29 +0000 (10:25 +0200)
From-SVN: r247145

gcc/ada/ChangeLog
gcc/ada/ada_get_targ.adb [new file with mode: 0644]

index 9899f93fe3faa0f60d90c89b0008ba60f184b733..d74dfff7e9a7dece415a9250c48202cfdd92db69 100644 (file)
@@ -1,3 +1,7 @@
+2017-04-25  Arnaud Charlet  <charlet@adacore.com>
+
+       * ada_get_targ.adb: New file.
+
 2017-04-25  Bob Duff  <duff@adacore.com>
 
        * uintp.adb (Most_Sig_2_Digits): In case Direct (Right), fetch
diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb
new file mode 100644 (file)
index 0000000..03b9144
--- /dev/null
@@ -0,0 +1,328 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             G E T _ T A R G                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT 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  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Version shared by various Ada based back-ends (e.g. gnat2scil, gnat2why)
+
+with System.OS_Lib; use System.OS_Lib;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+
+package body Get_Targ is
+
+   -----------------------
+   -- Get_Bits_Per_Unit --
+   -----------------------
+
+   function Get_Bits_Per_Unit return Pos is
+   begin
+      return 8;
+   end Get_Bits_Per_Unit;
+
+   -----------------------
+   -- Get_Bits_Per_Word --
+   -----------------------
+
+   function Get_Bits_Per_Word return Pos is
+   begin
+      return 32;
+   end Get_Bits_Per_Word;
+
+   -------------------
+   -- Get_Char_Size --
+   -------------------
+
+   function Get_Char_Size return Pos is
+   begin
+      return 8;
+   end Get_Char_Size;
+
+   -----------------
+   -- Get_Wchar_T --
+   -----------------
+
+   function Get_Wchar_T_Size return Pos is
+   begin
+      return 16;
+   end Get_Wchar_T_Size;
+
+   --------------------
+   -- Get_Short_Size --
+   --------------------
+
+   function Get_Short_Size return Pos is
+   begin
+      return 16;
+   end Get_Short_Size;
+
+   ------------------
+   -- Get_Int_Size --
+   ------------------
+
+   function Get_Int_Size return Pos is
+   begin
+      return 32;
+   end Get_Int_Size;
+
+   -------------------
+   -- Get_Long_Size --
+   -------------------
+
+   function Get_Long_Size return Pos is
+   begin
+      return 64;
+   end Get_Long_Size;
+
+   ------------------------
+   -- Get_Long_Long_Size --
+   ------------------------
+
+   function Get_Long_Long_Size return Pos is
+   begin
+      return 64;
+   end Get_Long_Long_Size;
+
+   ----------------------
+   -- Get_Pointer_Size --
+   ----------------------
+
+   function Get_Pointer_Size return Pos is
+   begin
+      return 64;
+   end Get_Pointer_Size;
+
+   ---------------------------
+   -- Get_Maximum_Alignment --
+   ---------------------------
+
+   function Get_Maximum_Alignment return Pos is
+   begin
+      return 4;
+   end Get_Maximum_Alignment;
+
+   ------------------------------------
+   -- Get_System_Allocator_Alignment --
+   ------------------------------------
+
+   function Get_System_Allocator_Alignment return Nat is
+   begin
+      return 1;
+   end Get_System_Allocator_Alignment;
+
+   ------------------------
+   -- Get_Float_Words_BE --
+   ------------------------
+
+   function Get_Float_Words_BE return Nat is
+   begin
+      return 1;
+   end Get_Float_Words_BE;
+
+   ------------------
+   -- Get_Words_BE --
+   ------------------
+
+   function Get_Words_BE return Nat is
+   begin
+      return 1;
+   end Get_Words_BE;
+
+   ------------------
+   -- Get_Bytes_BE --
+   ------------------
+
+   function Get_Bytes_BE return Nat is
+   begin
+      return 1;
+   end Get_Bytes_BE;
+
+   -----------------
+   -- Get_Bits_BE --
+   -----------------
+
+   function Get_Bits_BE return Nat is
+   begin
+      return 1;
+   end Get_Bits_BE;
+
+   ---------------------
+   -- Get_Short_Enums --
+   ---------------------
+
+   function Get_Short_Enums return Int is
+   begin
+      return 0;
+   end Get_Short_Enums;
+
+   --------------------------
+   -- Get_Strict_Alignment --
+   --------------------------
+
+   function Get_Strict_Alignment return Nat is
+   begin
+      return 1;
+   end Get_Strict_Alignment;
+
+   --------------------------------
+   -- Get_Double_Float_Alignment --
+   --------------------------------
+
+   function Get_Double_Float_Alignment return Nat is
+   begin
+      return 0;
+   end Get_Double_Float_Alignment;
+
+   ---------------------------------
+   -- Get_Double_Scalar_Alignment --
+   ---------------------------------
+
+   function Get_Double_Scalar_Alignment return Nat is
+   begin
+      return 0;
+   end Get_Double_Scalar_Alignment;
+
+   -----------------------------
+   -- Get_Max_Unaligned_Field --
+   -----------------------------
+
+   function Get_Max_Unaligned_Field return Pos is
+   begin
+      return 64;  -- Can be different on some targets (e.g., AAMP)
+   end Get_Max_Unaligned_Field;
+
+   ----------------------
+   -- Digits_From_Size --
+   ----------------------
+
+   function Digits_From_Size (Size : Pos) return Pos is
+   begin
+      case Size is
+         when  32    => return  6;
+         when  48    => return  9;
+         when  64    => return 15;
+         when  96    => return 18;
+         when 128    => return 18;
+         when others => raise Program_Error;
+      end case;
+   end Digits_From_Size;
+
+   -----------------------------
+   -- Register_Back_End_Types --
+   -----------------------------
+
+   procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is
+      Float_Str  : C_String := (others => ASCII.NUL);
+      Double_Str : C_String := (others => ASCII.NUL);
+
+   begin
+      Float_Str (Float_Str'First .. Float_Str'First + 4) := "float";
+      Call_Back
+        (C_Name => Float_Str, Digs => 6, Complex => False, Count  => 0,
+         Float_Rep => IEEE_Binary,
+         Precision => 32, Size => 32, Alignment => 32);
+
+      Double_Str (Double_Str'First .. Double_Str'First + 5) := "double";
+      Call_Back
+        (C_Name    => Double_Str,
+         Digs      => 15,
+         Complex   => False,
+         Count     => 0,
+         Float_Rep => IEEE_Binary,
+         Precision => 64,
+         Size      => 64,
+         Alignment => 64);
+   end Register_Back_End_Types;
+
+   ---------------------
+   -- Width_From_Size --
+   ---------------------
+
+   function Width_From_Size  (Size : Pos) return Pos is
+   begin
+      case Size is
+         when  8     => return  4;
+         when 16     => return  6;
+         when 32     => return 11;
+         when 64     => return 21;
+         when others => raise Program_Error;
+      end case;
+   end Width_From_Size;
+
+   ------------------------------
+   -- Get_Back_End_Config_File --
+   ------------------------------
+
+   function Get_Back_End_Config_File return String_Ptr is
+
+      function Exec_Name return String;
+      --  Return name of the current executable (from argv[0])
+
+      function Get_Target_File (Dir : String) return String_Ptr;
+      --  Return Dir & "target.atp" if found, null otherwise
+
+      ---------------
+      -- Exec_Name --
+      ---------------
+
+      function Exec_Name return String is
+         type Arg_Array is array (Nat) of Big_String_Ptr;
+         type Arg_Array_Ptr is access all Arg_Array;
+
+         gnat_argv : Arg_Array_Ptr;
+         pragma Import (C, gnat_argv);
+
+      begin
+         for J in 1 .. Natural'Last loop
+            if gnat_argv (0) (J) = ASCII.NUL then
+               return gnat_argv (0) (1 .. J - 1);
+            end if;
+         end loop;
+
+         raise Program_Error;
+      end Exec_Name;
+
+      ---------------------
+      -- Get_Target_File --
+      ---------------------
+
+      function Get_Target_File (Dir : String) return String_Ptr is
+         F : constant String := Dir & "target.atp";
+      begin
+         if Is_Regular_File (F) then
+            return new String'(F);
+         else
+            return null;
+         end if;
+      end Get_Target_File;
+
+      Exec : constant String := Exec_Name;
+
+   --  Start of processing for Get_Back_End_Config_File
+
+   begin
+      if Is_Absolute_Path (Exec) then
+         return Get_Target_File (Dir_Name (Exec));
+      else
+         return Get_Target_File (Dir_Name (Locate_Exec_On_Path (Exec).all));
+      end if;
+   end Get_Back_End_Config_File;
+
+end Get_Targ;