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