1------------------------------------------------------------------------------
2--                                                                          --
3--                            GNAT2XML COMPONENTS                           --
4--                                                                          --
5--                     G N A T 2 X M L . P R O J E C T S                    --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--                     Copyright (C) 2013-2014, AdaCore                     --
10--                                                                          --
11-- Gnat2xml is free software; you can redistribute it and/or modify it      --
12-- under terms of the  GNU General Public License  as published by the Free --
13-- Software Foundation;  either version 2,  or  (at your option)  any later --
14-- version. Gnat2xml is distributed  in the hope  that it will be useful,   --
15-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER-      --
16-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
17-- Public License for more details. You should have received a copy of the  --
18-- GNU General Public License distributed with GNAT; see file COPYING. If   --
19-- not, write to the Free Software Foundation, 59 Temple Place Suite 330,   --
20-- Boston, MA 02111-1307, USA.                                              --
21-- The gnat2xml tool was derived from the Avatox sources.                   --
22------------------------------------------------------------------------------
23
24pragma Ada_2012;
25
26with Ada.Directories;          use Ada.Directories;
27with Ada.Strings.Unbounded;    use Ada.Strings.Unbounded;
28
29with GNAT.OS_Lib;
30
31with GNATCOLL.Projects;        use GNATCOLL.Projects;
32
33with ASIS_UL.Common;           use ASIS_UL.Common;
34with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options;
35with ASIS_UL.Debug;            use ASIS_UL.Debug;
36with ASIS_UL.Environment;      use ASIS_UL.Environment;
37with ASIS_UL.Formatted_Output; use ASIS_UL.Formatted_Output;
38with ASIS_UL.Options;          use ASIS_UL.Options;
39with ASIS_UL.Output;           use ASIS_UL.Output;
40
41with Gnat2xml.Command_Line;    use Gnat2xml.Command_Line;
42
43package body Gnat2xml.Projects is
44
45   ----------------------
46   -- Print_Tool_Usage --
47   ----------------------
48
49   overriding procedure Print_Tool_Usage
50     (My_Project : Gnat2xml_Project_Type)
51   is
52      pragma Unreferenced (My_Project);
53   begin
54      Gnat2xml_Usage;
55   end Print_Tool_Usage;
56
57   ------------------------------
58   -- Register_Tool_Attributes --
59   ------------------------------
60
61   procedure Register_Tool_Attributes (My_Project : Gnat2xml_Project_Type) is
62      Pkg : constant String :=
63        Tool_Package_Name (Arg_Project_Type'Class (My_Project));
64      Dummy : String_Access;
65   begin
66      Dummy := new String'
67        (Register_New_Attribute
68           (Name    => "Default_Switches",
69            Pkg     => Pkg,
70            Is_List => True,
71            Indexed => True));
72
73      if Dummy.all /= "" then
74         Error ("cannot parse project file: " & Dummy.all);
75         raise Fatal_Error;
76      end if;
77      Free (Dummy);
78
79      Dummy := new String'
80        (Register_New_Attribute
81           (Name    => "Switches",
82            Pkg     => Pkg,
83            Is_List => True,
84            Indexed => True));
85
86      if Dummy.all /= "" then
87         Error ("cannot parse project file: " & Dummy.all);
88         raise Fatal_Error;
89      end if;
90      Free (Dummy);
91
92   end Register_Tool_Attributes;
93
94   --------------------
95   -- Scan_Arguments --
96   --------------------
97
98   overriding procedure Scan_Arguments
99     (My_Project  : in out Gnat2xml_Project_Type;
100      First_Pass  :        Boolean    := False;
101      Parser      :        Opt_Parser := Command_Line_Parser;
102      In_Switches :        Boolean    := False)
103   is
104      In_Project_File : constant Boolean := Parser /= Command_Line_Parser;
105      Initial_Char    :          Character;
106      Common_Arg : Common_Arg_Status;
107   begin
108      if First_Pass then
109         Warning_Mode := Quiet;
110         --  Otherwise an average run would generate too much diagnoses
111         --  about problems in reformatting
112
113         Process_RTL_Units := True;
114         --  We don't care about this
115
116      end if;
117
118      loop
119         Initial_Char :=
120           GNAT.Command_Line.Getopt
121             ("P: U X! eL "             &   --  project-specific options
122              "-subdirs= "              &
123              "-no_objects_dir "        &
124              Incremental_Switches      &
125              "j! " &
126              "-rep-clauses " &
127              "o= " & -- See Scan_Common_Arg
128              "I: -RTS= v q d? " &
129              "-compact " &
130              "files= " &
131              "h -help -version " &
132              "m: -output-dir=",
133               Parser => Parser);
134
135         --  Print command-line options for debugging
136
137         if False -- disable for now
138           and then ASIS_UL.Debug.Debug_Flag_1
139           and then (not First_Pass)
140           and then Initial_Char /= ASCII.NUL
141         then
142            declare
143               Param : constant String :=
144                 Strip_Prefix (Parameter (Parser => Parser), "=");
145            begin
146               Put
147                 ("\1 \2: ""\3"" = ""\4""\n",
148                  (if First_Pass then "1" else "2"),
149                    (1 => Initial_Char),
150                    Full_Switch (Parser => Parser),
151                    Param);
152
153               --  If the parameter refers to an existing file, print out the
154               --  contents of that file.
155
156               if Param /= ""
157                 and then Exists (Param)
158                 and then Kind (Param) = Ordinary_File
159               then
160                  declare
161                     File_Content : GNAT.OS_Lib.String_Access :=
162                       Read_File (Param);
163                  begin
164                     Put ("----------------\n\1----------------\n",
165                          File_Content.all);
166                     GNAT.OS_Lib.Free (File_Content);
167                  end;
168               end if;
169            end;
170         end if;
171
172         Common_Arg := Scan_Common_Arg
173           (My_Project, First_Pass, Parser, In_Switches,
174            In_Project_File, Initial_Char);
175         case Common_Arg is
176            when Arg_Processed => goto Continue; -- Dealt with above
177            when Arg_Not_Processed => null; -- Deal with it in 'case' below
178            when Quit => return; -- Ignore all other args
179         end case;
180
181         case Initial_Char is
182            when ASCII.NUL =>
183               exit when not
184                 More_Arguments
185                   (Store_Arguments => In_Project_File or else First_Pass,
186                    In_Switches     => In_Switches);
187
188            when 'e' =>
189
190               if Full_Switch (Parser => Parser) = "eL" then
191                  if First_Pass then
192                     ASIS_UL.Projects.Follow_Symbolic_Links := True;
193                  elsif In_Project_File then
194                     Error ("-eL option cannot be set in a project file");
195                     raise Parameter_Error;
196                  end if;
197               end if;
198
199            when 'h' =>
200               if Full_Switch (Parser => Parser) = "h" then
201                  if In_Project_File then
202                     Error ("project file should not contain '-h' option");
203                     raise Parameter_Error;
204                  end if;
205
206                  Print_Usage := True;
207                  return;
208               else
209                  pragma Assert (False);
210               end if;
211
212            when 'm' => --  Obsolete alternative to --output-dir
213               if not First_Pass then
214                  if Full_Switch (Parser => Parser) = "m" then
215                     --  In Incremental_Mode, -m won't work, because gnatmake
216                     --  and gprbuild process it with a different meaning. In
217                     --  non-Incremental_Mode, we continue to allow -m for
218                     --  compatibility.
219
220                     if Incremental_Mode then
221                        Error ("-m is obsolete; use --output-dir="
222                                 & Parameter (Parser => Parser) & " instead");
223                        raise Parameter_Error;
224                     end if;
225
226                     Out_Dir := new String'
227                       (Full_Name (Parameter (Parser => Parser)));
228                  else
229                     pragma Assert (False);
230                  end if;
231               end if;
232
233            when 'P' =>
234               if Full_Switch (Parser => Parser) = "P" then
235                  if First_Pass then
236                     My_Project.Store_Project_Source (Parameter);
237                  elsif In_Project_File then
238                     Error ("project file should not be specified inside " &
239                            "another project file");
240                     raise Parameter_Error;
241                  end if;
242               end if;
243
244            when 'q' =>
245               if not First_Pass then
246                  if Full_Switch (Parser => Parser) = "q" then
247                     Quiet_Mode := True;
248                  else
249                     pragma Assert (False);
250                  end if;
251               end if;
252
253            when 'U' =>
254               if Full_Switch (Parser => Parser) = "U" then
255                  if First_Pass then
256                     if ASIS_UL.Projects.U_Option_Set then
257                        Error ("-U can be specified only once");
258                        raise Parameter_Error;
259                     end if;
260
261                     ASIS_UL.Projects.U_Option_Set := True;
262                  elsif In_Project_File then
263                     Error ("-U option is not allowed in a project file");
264                     raise Parameter_Error;
265                  end if;
266               end if;
267
268            when 'x' =>
269               if not First_Pass then
270                  if Full_Switch (Parser => Parser) = "x" then
271                     null; -- ignore
272                  else
273                     pragma Assert (False);
274                  end if;
275               end if;
276
277            when 'X' =>
278               if Full_Switch (Parser => Parser) = "X" then
279                  if First_Pass then
280                     ASIS_UL.Projects.Store_External_Variable
281                       (Var => Parameter);
282                  elsif In_Project_File then
283                     Error ("external references cannot be set in " &
284                            "a project file");
285                     raise Parameter_Error;
286                  end if;
287               end if;
288
289            when '-' =>
290               if not First_Pass then
291                  if Full_Switch (Parser => Parser) = "-RTS" then
292                     Store_Option ("--RTS=" & Parameter (Parser => Parser));
293                  elsif Full_Switch (Parser => Parser) = "-subdirs" then
294                     Set_Subdir_Name (Parameter (Parser => Parser));
295                  elsif Full_Switch (Parser => Parser) = "-no_objects_dir" then
296                     No_Object_Dir := True;
297                  elsif Full_Switch (Parser => Parser) = "-compact" then
298                     Gnat2xml.Command_Line.Options.Compact_XML := True;
299                  else
300                     pragma Assert (False);
301                  end if;
302               else
303                  if Full_Switch (Parser => Parser) = "-RTS" then
304                     Store_RTS_Path (Parameter (Parser => Parser));
305                  end if;
306               end if;
307
308            when others =>
309               if not Mimic_gcc then
310                  --  Ignore unrecognized switches in the inner invocation
311                  Error
312                    ("unrecognized switch: " & Full_Switch (Parser => Parser));
313                  raise Program_Error;
314               end if;
315         end case;
316
317         <<Continue>>
318         --  Go here to skip the above case statement in the case when
319         --  Scan_Common_Arg already dealt with an argument.
320      end loop;
321
322      --  If there is an -asis-tool-args section (which only happens in the
323      --  inner invocations of incremental mode), we treat those args like
324      --  normal args. We do so by going to that section, and recursively
325      --  calling Scan_Arguments. See also ASIS_UL.Projects.Section_Delimiters.
326
327      if Current_Section (Parser => Parser) = "" then
328         Goto_Section ("asis-tool-args", Parser => Parser);
329         if Current_Section (Parser => Parser) = "-asis-tool-args" then
330            Scan_Arguments (My_Project, First_Pass, Parser, In_Switches);
331            Goto_Section ("", Parser => Parser);
332         else
333            pragma Assert (Current_Section (Parser => Parser) = "");
334         end if;
335
336         if not First_Pass or else In_Project_File then
337            ASIS_UL.Compiler_Options.Process_cargs_Section
338              (Parser, No_Preprocessing => True);
339         end if;
340
341         if Incremental_Mode_By_Default
342           and then My_Project.Is_Specified
343         then
344            pragma Assert (not Mimic_gcc);
345            Incremental_Mode := True;
346         end if;
347      else
348         --  We're in the recursive call; do nothing
349         pragma Assert
350           (Current_Section (Parser => Parser) = "-asis-tool-args");
351      end if;
352
353      --  Set_Gnat2xml_Options (Options);
354      --  Moved to Check_Parameters when the direct project support is added.
355
356   exception
357      when GNAT.Command_Line.Invalid_Switch =>
358         Error ("invalid switch : " & Full_Switch (Parser => Parser));
359         raise Parameter_Error;
360
361      when GNAT.Command_Line.Invalid_Parameter =>
362         Error ("parameter missed for : -" & Full_Switch (Parser => Parser));
363         raise Parameter_Error;
364
365   end Scan_Arguments;
366
367end Gnat2xml.Projects;
368