gcc/ada/ada_get_targ.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G E T _ T A R G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 ------------------------------------------------------------------------------
  22
  23 --  Version shared by various Ada based back-ends (e.g. gnat2scil, gnat2why)
  24
  25 with System.OS_Lib; use System.OS_Lib;
  26
  27 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  28
  29 package body Get_Targ is
  30
  31    -----------------------
  32    -- Get_Bits_Per_Unit --
  33    -----------------------
  34
  35    function Get_Bits_Per_Unit return Pos is
  36    begin
  37       return 8;
  38    end Get_Bits_Per_Unit;
  39
  40    -----------------------
  41    -- Get_Bits_Per_Word --
  42    -----------------------
  43
  44    function Get_Bits_Per_Word return Pos is
  45    begin
  46       return 32;
  47    end Get_Bits_Per_Word;
  48
  49    -------------------
  50    -- Get_Char_Size --
  51    -------------------
  52
  53    function Get_Char_Size return Pos is
  54    begin
  55       return 8;
  56    end Get_Char_Size;
  57
  58    ----------------------
  59    -- Get_Wchar_T_Size --
  60    ----------------------
  61
  62    function Get_Wchar_T_Size return Pos is
  63    begin
  64       return 16;
  65    end Get_Wchar_T_Size;
  66
  67    --------------------
  68    -- Get_Short_Size --
  69    --------------------
  70
  71    function Get_Short_Size return Pos is
  72    begin
  73       return 16;
  74    end Get_Short_Size;
  75
  76    ------------------
  77    -- Get_Int_Size --
  78    ------------------
  79
  80    function Get_Int_Size return Pos is
  81    begin
  82       return 32;
  83    end Get_Int_Size;
  84
  85    -------------------
  86    -- Get_Long_Size --
  87    -------------------
  88
  89    function Get_Long_Size return Pos is
  90    begin
  91       return 64;
  92    end Get_Long_Size;
  93
  94    ------------------------
  95    -- Get_Long_Long_Size --
  96    ------------------------
  97
  98    function Get_Long_Long_Size return Pos is
  99    begin
 100       return 64;
 101    end Get_Long_Long_Size;
 102
 103    -----------------------------
 104    -- Get_Long_Long_Long_Size --
 105    -----------------------------
 106
 107    function Get_Long_Long_Long_Size return Pos is
 108    begin
 109       return 64;
 110    end Get_Long_Long_Long_Size;
 111
 112    ----------------------
 113    -- Get_Pointer_Size --
 114    ----------------------
 115
 116    function Get_Pointer_Size return Pos is
 117    begin
 118       return 64;
 119    end Get_Pointer_Size;
 120
 121    ---------------------------
 122    -- Get_Maximum_Alignment --
 123    ---------------------------
 124
 125    function Get_Maximum_Alignment return Pos is
 126    begin
 127       return 4;
 128    end Get_Maximum_Alignment;
 129
 130    ------------------------
 131    -- Get_Float_Words_BE --
 132    ------------------------
 133
 134    function Get_Float_Words_BE return Nat is
 135    begin
 136       return 1;
 137    end Get_Float_Words_BE;
 138
 139    ------------------
 140    -- Get_Words_BE --
 141    ------------------
 142
 143    function Get_Words_BE return Nat is
 144    begin
 145       return 1;
 146    end Get_Words_BE;
 147
 148    ------------------
 149    -- Get_Bytes_BE --
 150    ------------------
 151
 152    function Get_Bytes_BE return Nat is
 153    begin
 154       return 1;
 155    end Get_Bytes_BE;
 156
 157    -----------------
 158    -- Get_Bits_BE --
 159    -----------------
 160
 161    function Get_Bits_BE return Nat is
 162    begin
 163       return 1;
 164    end Get_Bits_BE;
 165
 166    ---------------------
 167    -- Get_Short_Enums --
 168    ---------------------
 169
 170    function Get_Short_Enums return Int is
 171    begin
 172       return 0;
 173    end Get_Short_Enums;
 174
 175    --------------------------
 176    -- Get_Strict_Alignment --
 177    --------------------------
 178
 179    function Get_Strict_Alignment return Nat is
 180    begin
 181       return 1;
 182    end Get_Strict_Alignment;
 183
 184    ------------------------------------
 185    -- Get_System_Allocator_Alignment --
 186    ------------------------------------
 187
 188    function Get_System_Allocator_Alignment return Nat is
 189    begin
 190       return 1;
 191    end Get_System_Allocator_Alignment;
 192
 193    --------------------------------
 194    -- Get_Double_Float_Alignment --
 195    --------------------------------
 196
 197    function Get_Double_Float_Alignment return Nat is
 198    begin
 199       return 0;
 200    end Get_Double_Float_Alignment;
 201
 202    ---------------------------------
 203    -- Get_Double_Scalar_Alignment --
 204    ---------------------------------
 205
 206    function Get_Double_Scalar_Alignment return Nat is
 207    begin
 208       return 0;
 209    end Get_Double_Scalar_Alignment;
 210
 211    -----------------------------
 212    -- Register_Back_End_Types --
 213    -----------------------------
 214
 215    procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is
 216       Float_Str  : C_String := (others => ASCII.NUL);
 217       Double_Str : C_String := (others => ASCII.NUL);
 218
 219    begin
 220       Float_Str (Float_Str'First .. Float_Str'First + 4) := "float";
 221       Call_Back
 222         (C_Name => Float_Str, Digs => 6, Complex => False, Count  => 0,
 223          Float_Rep => IEEE_Binary,
 224          Precision => 32, Size => 32, Alignment => 32);
 225
 226       Double_Str (Double_Str'First .. Double_Str'First + 5) := "double";
 227       Call_Back
 228         (C_Name    => Double_Str,
 229          Digs      => 15,
 230          Complex   => False,
 231          Count     => 0,
 232          Float_Rep => IEEE_Binary,
 233          Precision => 64,
 234          Size      => 64,
 235          Alignment => 64);
 236    end Register_Back_End_Types;
 237
 238    ------------------------------
 239    -- Get_Back_End_Config_File --
 240    ------------------------------
 241
 242    function Get_Back_End_Config_File return String_Ptr is
 243
 244       function Exec_Name return String;
 245       --  Return name of the current executable (from argv[0])
 246
 247       function Get_Target_File (Dir : String) return String_Ptr;
 248       --  Return Dir & "target.atp" if found, null otherwise
 249
 250       ---------------
 251       -- Exec_Name --
 252       ---------------
 253
 254       function Exec_Name return String is
 255          type Arg_Array is array (Nat) of Big_String_Ptr;
 256          type Arg_Array_Ptr is access all Arg_Array;
 257
 258          gnat_argv : Arg_Array_Ptr;
 259          pragma Import (C, gnat_argv);
 260
 261       begin
 262          for J in 1 .. Natural'Last loop
 263             if gnat_argv (0) (J) = ASCII.NUL then
 264                return gnat_argv (0) (1 .. J - 1);
 265             end if;
 266          end loop;
 267
 268          raise Program_Error;
 269       end Exec_Name;
 270
 271       ---------------------
 272       -- Get_Target_File --
 273       ---------------------
 274
 275       function Get_Target_File (Dir : String) return String_Ptr is
 276          F : constant String := Dir & "target.atp";
 277       begin
 278          if Is_Regular_File (F) then
 279             return new String'(F);
 280          else
 281             return null;
 282          end if;
 283       end Get_Target_File;
 284
 285       Exec : constant String := Exec_Name;
 286
 287    --  Start of processing for Get_Back_End_Config_File
 288
 289    begin
 290       if Is_Absolute_Path (Exec) then
 291          return Get_Target_File (Dir_Name (Exec));
 292       else
 293          return Get_Target_File (Dir_Name (Locate_Exec_On_Path (Exec).all));
 294       end if;
 295    end Get_Back_End_Config_File;
 296
 297 end Get_Targ;