1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                            B A C K _ E N D                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26--  This is the version of the Back_End package for GCC back ends
27
28with Atree;    use Atree;
29with Debug;    use Debug;
30with Elists;   use Elists;
31with Errout;   use Errout;
32with Lib;      use Lib;
33with Osint;    use Osint;
34with Opt;      use Opt;
35with Osint.C;  use Osint.C;
36with Namet;    use Namet;
37with Nlists;   use Nlists;
38with Stand;    use Stand;
39with Sinput;   use Sinput;
40with Stringt;  use Stringt;
41with Switch;   use Switch;
42with Switch.C; use Switch.C;
43with System;   use System;
44with Types;    use Types;
45
46with System.OS_Lib; use System.OS_Lib;
47
48package body Back_End is
49
50   type Arg_Array is array (Nat) of Big_String_Ptr;
51   type Arg_Array_Ptr is access Arg_Array;
52   --  Types to access compiler arguments
53
54   flag_stack_check : Int;
55   pragma Import (C, flag_stack_check);
56   --  Indicates if stack checking is enabled, imported from misc.c
57
58   save_argc : Nat;
59   pragma Import (C, save_argc);
60   --  Saved value of argc (number of arguments), imported from misc.c
61
62   save_argv : Arg_Array_Ptr;
63   pragma Import (C, save_argv);
64   --  Saved value of argv (argument pointers), imported from misc.c
65
66   function Len_Arg (Arg : Pos) return Nat;
67   --  Determine length of argument number Arg on original gnat1 command line
68
69   -------------------
70   -- Call_Back_End --
71   -------------------
72
73   procedure Call_Back_End (Mode : Back_End_Mode_Type) is
74
75      --  The Source_File_Record type has a lot of components that are
76      --  meaningless to the back end, so a new record type is created
77      --  here to contain the needed information for each file.
78
79      type File_Info_Type is record
80         File_Name        : File_Name_Type;
81         Instance         : Instance_Id;
82         Num_Source_Lines : Nat;
83      end record;
84
85      File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type;
86
87      procedure gigi
88        (gnat_root                     : Int;
89         max_gnat_node                 : Int;
90         number_name                   : Nat;
91         nodes_ptr                     : Address;
92         flags_ptr                     : Address;
93
94         next_node_ptr                 : Address;
95         prev_node_ptr                 : Address;
96         elists_ptr                    : Address;
97         elmts_ptr                     : Address;
98
99         strings_ptr                   : Address;
100         string_chars_ptr              : Address;
101         list_headers_ptr              : Address;
102         number_file                   : Nat;
103
104         file_info_ptr                 : Address;
105         gigi_standard_boolean         : Entity_Id;
106         gigi_standard_integer         : Entity_Id;
107         gigi_standard_character       : Entity_Id;
108         gigi_standard_long_long_float : Entity_Id;
109         gigi_standard_exception_type  : Entity_Id;
110         gigi_operating_mode           : Back_End_Mode_Type);
111
112      pragma Import (C, gigi);
113
114   begin
115      --  Skip call if in -gnatdH mode
116
117      if Debug_Flag_HH then
118         return;
119      end if;
120
121      --  The back end needs to know the maximum line number that can appear
122      --  in a Sloc, in other words the maximum logical line number.
123
124      for J in 1 .. Last_Source_File loop
125         File_Info_Array (J).File_Name        := Full_Debug_Name (J);
126         File_Info_Array (J).Instance         := Instance (J);
127         File_Info_Array (J).Num_Source_Lines :=
128           Nat (Physical_To_Logical (Last_Source_Line (J), J));
129      end loop;
130
131      --  Deal with case of generating SCIL, we should not be here unless
132      --  debugging CodePeer mode in GNAT.
133
134      if Generate_SCIL then
135         Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit));
136
137         if CodePeer_Mode
138           or else (Mode /= Generate_Object
139                     and then not Back_Annotate_Rep_Info)
140         then
141            return;
142         end if;
143      end if;
144
145      --  We should be here in GNATprove mode only when debugging GNAT. Do not
146      --  call gigi in that case, as it is not prepared to handle the special
147      --  form of the tree obtained in GNATprove mode.
148
149      if GNATprove_Mode then
150         return;
151      end if;
152
153      --  The actual call to the back end
154
155      gigi
156        (gnat_root          => Int (Cunit (Main_Unit)),
157         max_gnat_node      => Int (Last_Node_Id - First_Node_Id + 1),
158         number_name        => Name_Entries_Count,
159         nodes_ptr          => Nodes_Address,
160         flags_ptr          => Flags_Address,
161
162         next_node_ptr      => Next_Node_Address,
163         prev_node_ptr      => Prev_Node_Address,
164         elists_ptr         => Elists_Address,
165         elmts_ptr          => Elmts_Address,
166
167         strings_ptr        => Strings_Address,
168         string_chars_ptr   => String_Chars_Address,
169         list_headers_ptr   => Lists_Address,
170         number_file        => Num_Source_Files,
171
172         file_info_ptr                 => File_Info_Array'Address,
173         gigi_standard_boolean         => Standard_Boolean,
174         gigi_standard_integer         => Standard_Integer,
175         gigi_standard_character       => Standard_Character,
176         gigi_standard_long_long_float => Standard_Long_Long_Float,
177         gigi_standard_exception_type  => Standard_Exception_Type,
178         gigi_operating_mode           => Mode);
179   end Call_Back_End;
180
181   -------------------------------
182   -- Gen_Or_Update_Object_File --
183   -------------------------------
184
185   procedure Gen_Or_Update_Object_File is
186   begin
187      null;
188   end Gen_Or_Update_Object_File;
189
190   -------------
191   -- Len_Arg --
192   -------------
193
194   function Len_Arg (Arg : Pos) return Nat is
195   begin
196      for J in 1 .. Nat'Last loop
197         if save_argv (Arg).all (Natural (J)) = ASCII.NUL then
198            return J - 1;
199         end if;
200      end loop;
201
202      raise Program_Error;
203   end Len_Arg;
204
205   -----------------------------
206   -- Scan_Compiler_Arguments --
207   -----------------------------
208
209   procedure Scan_Compiler_Arguments is
210      Next_Arg : Positive;
211      --  Next argument to be scanned
212
213      Arg_Count : constant Natural := Natural (save_argc - 1);
214      Args      : Argument_List (1 .. Arg_Count);
215
216      Output_File_Name_Seen : Boolean := False;
217      --  Set to True after having scanned file_name for switch "-gnatO file"
218
219      procedure Scan_Back_End_Switches (Switch_Chars : String);
220      --  Procedure to scan out switches stored in Switch_Chars. The first
221      --  character is known to be a valid switch character, and there are no
222      --  blanks or other switch terminator characters in the string, so the
223      --  entire string should consist of valid switch characters, except that
224      --  an optional terminating NUL character is allowed.
225      --
226      --  Back end switches have already been checked and processed by GCC in
227      --  toplev.c, so no errors can occur and control will always return. The
228      --  switches must still be scanned to skip "-o" or internal GCC switches
229      --  with their argument.
230
231      ----------------------------
232      -- Scan_Back_End_Switches --
233      ----------------------------
234
235      procedure Scan_Back_End_Switches (Switch_Chars : String) is
236         First : constant Positive := Switch_Chars'First + 1;
237         Last  : constant Natural  := Switch_Last (Switch_Chars);
238
239      begin
240         --  Skip -o or internal GCC switches together with their argument
241
242         if Switch_Chars (First .. Last) = "o"
243           or else Is_Internal_GCC_Switch (Switch_Chars)
244         then
245            Next_Arg := Next_Arg + 1;
246
247         --  Store -G xxx as -Gxxx and go directly to the next argument
248
249         elsif Switch_Chars (First .. Last) = "G" then
250            Next_Arg := Next_Arg + 1;
251
252            --  Should never get there with -G not followed by an argument,
253            --  but use defensive code nonetheless. Store as -Gxxx to avoid
254            --  storing parameters in ALI files that might create confusion.
255
256            if Next_Arg <= Args'Last then
257               Store_Compilation_Switch (Switch_Chars & Args (Next_Arg).all);
258            end if;
259
260         --  Do not record -quiet switch
261
262         elsif Switch_Chars (First .. Last) = "quiet" then
263            null;
264
265         --  Store any other GCC switches. Also do special processing for some
266         --  specific switches that the Ada front-end knows about.
267
268         else
269            Store_Compilation_Switch (Switch_Chars);
270
271            --  For gcc back ends, -fno-inline disables Inline pragmas only,
272            --  not Inline_Always to remain consistent with the always_inline
273            --  attribute behavior.
274
275            if Switch_Chars (First .. Last) = "fno-inline" then
276               Opt.Disable_FE_Inline := True;
277
278            --  Back end switch -fpreserve-control-flow also sets the front end
279            --  flag that inhibits improper control flow transformations.
280
281            elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then
282               Opt.Suppress_Control_Flow_Optimizations := True;
283
284            --  Back end switch -fdump-scos, which exists primarily for C, is
285            --  also accepted for Ada as a synonym of -gnateS.
286
287            elsif Switch_Chars (First .. Last) = "fdump-scos" then
288               Opt.Generate_SCO := True;
289               Opt.Generate_SCO_Instance_Table := True;
290
291            elsif Switch_Chars (First) = 'g' then
292               Debugger_Level := 2;
293
294               if First < Last then
295                  case Switch_Chars (First + 1) is
296                     when '0' =>
297                        Debugger_Level := 0;
298                     when '1' =>
299                        Debugger_Level := 1;
300                     when '2' =>
301                        Debugger_Level := 2;
302                     when '3' =>
303                        Debugger_Level := 3;
304                     when others =>
305                        null;
306                  end case;
307               end if;
308            end if;
309         end if;
310      end Scan_Back_End_Switches;
311
312   --  Start of processing for Scan_Compiler_Arguments
313
314   begin
315      --  Acquire stack checking mode directly from GCC. The reason we do this
316      --  is to make sure that the indication of stack checking being enabled
317      --  is the same in the front end and the back end. This status obtained
318      --  from gcc is affected by more than just the switch -fstack-check.
319
320      Opt.Stack_Checking_Enabled := (flag_stack_check /= 0);
321
322      --  Put the arguments in Args
323
324      for Arg in Pos range 1 .. save_argc - 1 loop
325         declare
326            Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
327            Argv_Len : constant Nat            := Len_Arg (Arg);
328            Argv     : constant String         :=
329                         Argv_Ptr (1 .. Natural (Argv_Len));
330         begin
331            Args (Positive (Arg)) := new String'(Argv);
332         end;
333      end loop;
334
335      --  Loop through command line arguments, storing them for later access
336
337      Next_Arg := 1;
338      while Next_Arg <= Args'Last loop
339         Look_At_Arg : declare
340            Argv : constant String := Args (Next_Arg).all;
341
342         begin
343            --  If the previous switch has set the Output_File_Name_Present
344            --  flag (that is we have seen a -gnatO), then the next argument
345            --  is the name of the output object file.
346
347            if Output_File_Name_Present and then not Output_File_Name_Seen then
348               if Is_Switch (Argv) then
349                  Fail ("Object file name missing after -gnatO");
350               else
351                  Set_Output_Object_File_Name (Argv);
352                  Output_File_Name_Seen := True;
353               end if;
354
355            --  If the previous switch has set the Search_Directory_Present
356            --  flag (that is if we have just seen -I), then the next argument
357            --  is a search directory path.
358
359            elsif Search_Directory_Present then
360               if Is_Switch (Argv) then
361                  Fail ("search directory missing after -I");
362               else
363                  Add_Src_Search_Dir (Argv);
364                  Search_Directory_Present := False;
365               end if;
366
367            --  If not a switch, must be a file name
368
369            elsif not Is_Switch (Argv) then
370               Add_File (Argv);
371
372            --  We must recognize -nostdinc to suppress visibility on the
373            --  standard GNAT RTL sources. This is also a gcc switch.
374
375            elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then
376               Opt.No_Stdinc := True;
377               Scan_Back_End_Switches (Argv);
378
379            --  We must recognize -nostdlib to suppress visibility on the
380            --  standard GNAT RTL objects.
381
382            elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
383               Opt.No_Stdlib := True;
384
385            elsif Is_Front_End_Switch (Argv) then
386               Scan_Front_End_Switches (Argv, Args, Next_Arg);
387
388            elsif Argv (Argv'First + 1 .. Argv'Last) = "fopenacc" then
389               Opt.OpenAcc_Enabled := True;
390
391            --  All non-front-end switches are back-end switches
392
393            else
394               Scan_Back_End_Switches (Argv);
395            end if;
396         end Look_At_Arg;
397
398         Next_Arg := Next_Arg + 1;
399      end loop;
400   end Scan_Compiler_Arguments;
401
402end Back_End;
403