procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* adabkend.ads, adabkend.adb, aa_util.ads, aa_util.adb: New.

Browse source 
From-SVN: r192913
This commit is contained in:
Arnaud Charlet 2012-10-29 09:50:53 +00:00 • committed by Arnaud Charlet
parent 6e58a0b759
commit e63f29e814
5 changed files with 939 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
gcc/ada/ChangeLog
View file

@ -1,6 +1,7 @@
2012-10-29 Arnaud Charlet <charlet@adacore.com>
* pprint.ads, pprint.adb: New.
* pprint.ads, pprint.adb, adabkend.ads, adabkend.adb,
aa_util.ads, aa_util.adb: New.
2012-10-23 Eric Botcazou <ebotcazou@adacore.com>

458
gcc/ada/aa_util.adb Normal file
View file

@ -0,0 +1,458 @@
------------------------------------------------------------------------------
-- --
-- GNAAMP COMPILER COMPONENTS --
-- --
-- A A _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
with Sem_Aux; use Sem_Aux;
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;
with GNAT.Case_Util; use GNAT.Case_Util;
package body AA_Util is
----------------------
-- Is_Global_Entity --
----------------------
function Is_Global_Entity (E : Entity_Id) return Boolean is
begin
return Enclosing_Dynamic_Scope (E) = Standard_Standard;
end Is_Global_Entity;
-----------------
-- New_Name_Id --
-----------------
function New_Name_Id (Name : String) return Name_Id is
begin
for J in 1 .. Name'Length loop
Name_Buffer (J) := Name (Name'First + (J - 1));
end loop;
Name_Len := Name'Length;
return Name_Find;
end New_Name_Id;
-----------------
-- Name_String --
-----------------
function Name_String (Name : Name_Id) return String is
begin
pragma Assert (Name /= No_Name);
return Get_Name_String (Name);
end Name_String;
-------------------
-- New_String_Id --
-------------------
function New_String_Id (S : String) return String_Id is
begin
for J in 1 .. S'Length loop
Name_Buffer (J) := S (S'First + (J - 1));
end loop;
Name_Len := S'Length;
return String_From_Name_Buffer;
end New_String_Id;
------------------
-- String_Value --
------------------
function String_Value (Str_Id : String_Id) return String is
begin
-- ??? pragma Assert (Str_Id /= No_String);
if Str_Id = No_String then
return "";
end if;
String_To_Name_Buffer (Str_Id);
return Name_Buffer (1 .. Name_Len);
end String_Value;
---------------
-- Next_Name --
---------------
function Next_Name
(Name_Seq : not null access Name_Sequencer;
Name_Prefix : String) return Name_Id
is
begin
Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1;
declare
Number_Image : constant String := Name_Seq.Sequence_Number'Img;
begin
return New_Name_Id
(Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last));
end;
end Next_Name;
--------------------
-- Elab_Spec_Name --
--------------------
function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is
begin
return New_Name_Id (Name_String (Module_Name) & "___elabs");
end Elab_Spec_Name;
--------------------
-- Elab_Spec_Name --
--------------------
function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is
begin
return New_Name_Id (Name_String (Module_Name) & "___elabb");
end Elab_Body_Name;
--------------------------------
-- Source_Name_Without_Suffix --
--------------------------------
function File_Name_Without_Suffix (File_Name : String) return String is
Name_Index : Natural := File_Name'Last;
begin
pragma Assert (File_Name'Length > 0);
-- We loop in reverse to ensure that file names that follow nonstandard
-- naming conventions that include additional dots are handled properly,
-- preserving dots in front of the main file suffix (for example,
-- main.2.ada => main.2).
while Name_Index >= File_Name'First
and then File_Name (Name_Index) /= '.'
loop
Name_Index := Name_Index - 1;
end loop;
-- Return the part of the file name up to but not including the last dot
-- in the name, or return the whole name as is if no dot character was
-- found.
if Name_Index >= File_Name'First then
return File_Name (File_Name'First .. Name_Index - 1);
else
return File_Name;
end if;
end File_Name_Without_Suffix;
-----------------
-- Source_Name --
-----------------
function Source_Name (Sloc : Source_Ptr) return File_Name_Type is
begin
if Sloc = No_Location or Sloc = Standard_Location then
return No_File;
else
return File_Name (Get_Source_File_Index (Sloc));
end if;
end Source_Name;
--------------------------------
-- Source_Name_Without_Suffix --
--------------------------------
function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is
Src_Name : constant String :=
Name_String (Name_Id (Source_Name (Sloc)));
Src_Index : Natural := Src_Name'Last;
begin
pragma Assert (Src_Name'Length > 0);
-- Treat the presence of a ".dg" suffix specially, stripping it off
-- in addition to any suffix preceding it.
if Src_Name'Length >= 4
and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg"
then
Src_Index := Src_Index - 3;
end if;
return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index));
end Source_Name_Without_Suffix;
----------------------
-- Source_Id_String --
----------------------
function Source_Id_String (Unit_Name : Name_Id) return String is
Unit_String : String := Name_String (Unit_Name);
Name_Last : Positive := Unit_String'Last;
Name_Index : Positive := Unit_String'First;
begin
To_Mixed (Unit_String);
-- Replace any embedded sequences of two or more '_' characters
-- with a single '.' character. Note that this will leave any
-- leading or trailing single '_' characters untouched, but those
-- should normally not occur in compilation unit names (and if
-- they do then it's better to leave them as is).
while Name_Index <= Name_Last loop
if Unit_String (Name_Index) = '_'
and then Name_Index /= Name_Last
and then Unit_String (Name_Index + 1) = '_'
then
Unit_String (Name_Index) := '.';
Name_Index := Name_Index + 1;
while Unit_String (Name_Index) = '_'
and then Name_Index <= Name_Last
loop
Unit_String (Name_Index .. Name_Last - 1)
:= Unit_String (Name_Index + 1 .. Name_Last);
Name_Last := Name_Last - 1;
end loop;
else
Name_Index := Name_Index + 1;
end if;
end loop;
return Unit_String (Unit_String'First .. Name_Last);
end Source_Id_String;
-- This version of Source_Id_String is obsolescent and is being
-- replaced with the above function.
function Source_Id_String (Sloc : Source_Ptr) return String is
File_Index : Source_File_Index;
begin
-- Use an arbitrary artificial 22-character value for package Standard,
-- since Standard doesn't have an associated source file.
if Sloc <= Standard_Location then
return "20010101010101standard";
-- Return the concatentation of the source file's timestamp and
-- its 8-digit hex checksum.
else
File_Index := Get_Source_File_Index (Sloc);
return String (Time_Stamp (File_Index))
& Get_Hex_String (Source_Checksum (File_Index));
end if;
end Source_Id_String;
---------------
-- Source_Id --
---------------
function Source_Id (Unit_Name : Name_Id) return String_Id is
begin
return New_String_Id (Source_Id_String (Unit_Name));
end Source_Id;
-- This version of Source_Id is obsolescent and is being
-- replaced with the above function.
function Source_Id (Sloc : Source_Ptr) return String_Id is
begin
return New_String_Id (Source_Id_String (Sloc));
end Source_Id;
-----------
-- Image --
-----------
function Image (I : Int) return String is
Image_String : constant String := Pos'Image (I);
begin
if Image_String (1) = ' ' then
return Image_String (2 .. Image_String'Last);
else
return Image_String;
end if;
end Image;
--------------
-- UI_Image --
--------------
function UI_Image (I : Uint; Format : Integer_Image_Format) return String is
begin
if Format = Decimal then
UI_Image (I, Format => Decimal);
return UI_Image_Buffer (1 .. UI_Image_Length);
elsif Format = Ada_Hex then
UI_Image (I, Format => Hex);
return UI_Image_Buffer (1 .. UI_Image_Length);
else
pragma Assert (I >= Uint_0);
UI_Image (I, Format => Hex);
pragma Assert (UI_Image_Buffer (1 .. 3) = "16#"
and then UI_Image_Buffer (UI_Image_Length) = '#');
-- Declare a string where we will copy the digits from the UI_Image,
-- interspersing '_' characters as 4-digit group separators. The
-- underscores in UI_Image's result are not always at the places
-- where we want them, which is why we do the following copy
-- (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^").
declare
Hex_String : String (1 .. UI_Image_Max);
Last_Index : Natural;
Digit_Count : Natural := 0;
UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket
Sep_Count : Natural := 0;
begin
-- Count up the number of non-underscore characters in the
-- literal value portion of the UI_Image string.
while UI_Image_Buffer (UI_Image_Index) /= '#' loop
if UI_Image_Buffer (UI_Image_Index) /= '_' then
Digit_Count := Digit_Count + 1;
end if;
UI_Image_Index := UI_Image_Index + 1;
end loop;
UI_Image_Index := 4; -- Reset the index past the "16#" bracket
Last_Index := 1;
Hex_String (Last_Index) := '^';
Last_Index := Last_Index + 1;
-- Copy digits from UI_Image_Buffer to Hex_String, adding
-- underscore separators as appropriate. The initial value
-- of Sep_Count accounts for the leading '^' and being one
-- character ahead after inserting a digit.
Sep_Count := 2;
while UI_Image_Buffer (UI_Image_Index) /= '#' loop
if UI_Image_Buffer (UI_Image_Index) /= '_' then
Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index);
Last_Index := Last_Index + 1;
-- Add '_' characters to separate groups of four hex
-- digits for readability (grouping from right to left).
if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then
Hex_String (Last_Index) := '_';
Last_Index := Last_Index + 1;
Sep_Count := Sep_Count + 1;
end if;
end if;
UI_Image_Index := UI_Image_Index + 1;
end loop;
-- Back up before any trailing underscore
if Hex_String (Last_Index - 1) = '_' then
Last_Index := Last_Index - 1;
end if;
Hex_String (Last_Index) := '^';
return Hex_String (1 .. Last_Index);
end;
end if;
end UI_Image;
--------------
-- UR_Image --
--------------
-- Shouldn't this be added to Urealp???
function UR_Image (R : Ureal) return String is
-- The algorithm used here for conversion of Ureal values
-- is taken from the JGNAT back end.
Num : Long_Long_Float := 0.0;
Den : Long_Long_Float := 0.0;
Sign : Long_Long_Float := 1.0;
Result : Long_Long_Float;
Tmp : Uint;
Index : Integer;
begin
if UR_Is_Negative (R) then
Sign := -1.0;
end if;
-- In the following calculus, we consider numbers modulo 2 ** 31,
-- so that we don't have problems with signed Int...
Tmp := abs (Numerator (R));
Index := 0;
while Tmp > 0 loop
Num := Num
+ Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
* (2.0 ** Index);
Tmp := Tmp / Uint_2 ** 31;
Index := Index + 31;
end loop;
Tmp := abs (Denominator (R));
if Rbase (R) /= 0 then
Tmp := Rbase (R) ** Tmp;
end if;
Index := 0;
while Tmp > 0 loop
Den := Den
+ Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
* (2.0 ** Index);
Tmp := Tmp / Uint_2 ** 31;
Index := Index + 31;
end loop;
-- If the denominator denotes a negative power of Rbase,
-- then multiply by the denominator.
if Rbase (R) /= 0 and then Denominator (R) < 0 then
Result := Sign * Num * Den;
-- Otherwise compute the quotient
else
Result := Sign * Num / Den;
end if;
return Long_Long_Float'Image (Result);
end UR_Image;
end AA_Util;

145
gcc/ada/aa_util.ads Normal file
View file

@ -0,0 +1,145 @@
------------------------------------------------------------------------------
-- --
-- GNAAMP COMPILER COMPONENTS --
-- --
-- A A _ U T I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2011, AdaCore --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- This package provides various utility operations used by GNAT back-ends
-- (e.g. AAMP).
-- This package is a messy grab bag of stuff. These routines should be moved
-- to appropriate units (sem_util,sem_aux,exp_util,namet,uintp,urealp). ???
with Namet; use Namet;
with Types; use Types;
with Uintp; use Uintp;
with Urealp; use Urealp;
package AA_Util is
function Is_Global_Entity (E : Entity_Id) return Boolean;
-- Returns true if and only if E is a library-level entity (excludes
-- entities declared within blocks at the outer level of library packages).
function New_Name_Id (Name : String) return Name_Id;
-- Returns a Name_Id corresponding to the given name string
function Name_String (Name : Name_Id) return String;
-- Returns the name string associated with Name
function New_String_Id (S : String) return String_Id;
-- Returns a String_Id corresponding to the given string
function String_Value (Str_Id : String_Id) return String;
-- Returns the string associated with Str_Id
-- Name-generation utilities
type Name_Sequencer is private;
-- This type is used to support back-end generation of unique symbol
-- (e.g., for string literal objects or labels). By declaring an
-- aliased object of type Name_Sequence and passing that object
-- to the function Next_Name, a series of names with suffixes
-- of the form "__n" will be produced, where n is a string denoting
-- a positive integer. The sequence starts with "__1", and increases
-- by one on each successive call to Next_Name for a given Name_Sequencer.
function Next_Name
(Name_Seq : not null access Name_Sequencer;
Name_Prefix : String) return Name_Id;
-- Returns the Name_Id for a name composed of the given Name_Prefix
-- concatentated with a unique number suffix of the form "__n",
-- as detemined by the current state of Name_Seq.
function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id;
-- Returns a name id for the elaboration subprogram to be associated with
-- the specification of the named module. The denoted name is of the form
-- "modulename___elabs".
function Elab_Body_Name (Module_Name : Name_Id) return Name_Id;
-- Returns a name id for the elaboration subprogram to be associated
-- with the body of the named module. The denoted name is of the form
-- "modulename___elabb".
function File_Name_Without_Suffix (File_Name : String) return String;
-- Removes the suffix ('.' followed by other characters), if present, from
-- the end of File_Name and returns the shortened name (otherwise simply
-- returns File_Name).
function Source_Name (Sloc : Source_Ptr) return File_Name_Type;
-- Returns file name corresponding to the source file name associated with
-- the given source position Sloc.
function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String;
-- Returns a string corresponding to the source file name associated with
-- the given source position Sloc, with its dot-preceded suffix, if any,
-- removed. As examples, the name "main.adb" is mapped to "main" and the
-- name "main.2.ada" is mapped to "main.2". As a special case, file names
-- with a ".dg" suffix will also strip off the ".dg", so "main.adb.dg"
-- becomes simply "main".
function Source_Id_String (Unit_Name : Name_Id) return String;
-- Returns a string that uniquely identifies the unit with the given
-- Unit_Name. This string is derived from Unit_Name by replacing any
-- multiple underscores with dot ('.') characters and normalizing the
-- casing to mixed case (e.g., "ada__strings" is mapped to ("Ada.Strings").
function Source_Id (Unit_Name : Name_Id) return String_Id;
-- Returns a String_Id reference to a string that uniquely identifies
-- the program unit having the given name (as defined for function
-- Source_Id_String).
function Source_Id_String (Sloc : Source_Ptr) return String;
-- Returns a string that uniquely identifies the source file containing
-- the given source location. This string is constructed from the
-- concatentation of the date and time stamp of the file with a
-- hexadecimal check sum (e.g., "020425143059ABCDEF01").
function Source_Id (Sloc : Source_Ptr) return String_Id;
-- Returns a String_Id reference to a string that uniquely identifies the
-- source file containing the given source location (as defined for
-- function Source_Id_String).
function Image (I : Int) return String;
-- Returns Int'Image (I), but without a leading space in the case where
-- I is nonnegative. Useful for concatenating integers onto other names.
type Integer_Image_Format is (Decimal, Ada_Hex, AAMP_Hex);
function UI_Image (I : Uint; Format : Integer_Image_Format) return String;
-- Returns the image of the universal integer I, with no leading spaces
-- and in the format specified. The Format parameter specifies whether
-- the integer representation should be decimal (the default), or Ada
-- hexadecimal (Ada_Hex => "16#xxxxx#" format), or AAMP hexadecimal.
-- In the latter case, the integer will have the form of a sequence of
-- hexadecimal digits bracketed by '^' characters, and will contain '_'
-- characters as separators for groups of four hexadecimal digits
-- (e.g., ^1C_A3CD^). If the format AAMP_Hex is selected, the universal
-- integer must have a nonnegative value.
function UR_Image (R : Ureal) return String;
-- Returns a decimal image of the universal real value R
private
type Name_Sequencer is record
Sequence_Number : Natural := 0;
end record;
end AA_Util;

282
gcc/ada/adabkend.adb Normal file
View file

@ -0,0 +1,282 @@
------------------------------------------------------------------------------
-- --
-- GNAAMP COMPILER COMPONENTS --
-- --
-- A D A B K E N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2011, AdaCore --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
-- This is the version of the Back_End package for back ends written in Ada
with Debug;
with Lib;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
with Osint.C; use Osint.C;
with Switch.C; use Switch.C;
with Types; use Types;
with System.OS_Lib; use System.OS_Lib;
package body Adabkend is
use Switch;
-------------------
-- Call_Back_End --
-------------------
procedure Call_Back_End is
begin
if (Opt.Verbose_Mode or Opt.Full_List)
and then not Debug.Debug_Flag_7
then
Write_Eol;
Write_Str (Product_Name);
Write_Str (", Copyright ");
Write_Str (Copyright_Years);
Write_Str (" Ada Core Technologies, Inc.");
Write_Str (" (http://www.adacore.com)");
Write_Eol;
Write_Eol;
end if;
Driver (Lib.Cunit (Types.Main_Unit));
end Call_Back_End;
------------------------
-- Scan_Compiler_Args --
------------------------
procedure Scan_Compiler_Arguments is
Output_File_Name_Seen : Boolean := False;
-- Set to True after having scanned the file_name for switch
-- "-gnatO file_name"
Argument_Count : constant Integer := Arg_Count - 1;
-- Number of arguments (excluding program name)
Args : Argument_List (1 .. Argument_Count);
Next_Arg : Positive := 1;
procedure Scan_Back_End_Switches (Switch_Chars : String);
-- Procedure to scan out switches stored in Switch_Chars. The first
-- character is known to be a valid switch character, and there are no
-- blanks or other switch terminator characters in the string, so the
-- entire string should consist of valid switch characters, except that
-- an optional terminating NUL character is allowed.
--
-- If the switch is not valid, control will not return. The switches
-- must still be scanned to skip the "-o" arguments, or internal GCC
-- switches, which may be safely ignored by other back-ends.
----------------------------
-- Scan_Back_End_Switches --
----------------------------
procedure Scan_Back_End_Switches (Switch_Chars : String) is
First : constant Positive := Switch_Chars'First + 1;
Last : constant Natural := Switch_Last (Switch_Chars);
begin
-- Process any back end switches, returning if the switch does not
-- affect code generation or falling through if it does, so the
-- switch will get stored.
if Is_Internal_GCC_Switch (Switch_Chars) then
Next_Arg := Next_Arg + 1;
return; -- ignore this switch
-- Record that an object file name has been specified. The actual
-- file name argument is picked up and saved below by the main body
-- of Scan_Compiler_Arguments.
elsif Switch_Chars (First .. Last) = "o" then
if First = Last then
Opt.Output_File_Name_Present := True;
return;
else
Fail ("invalid switch: " & Switch_Chars);
end if;
-- Set optimization indicators appropriately. In gcc-based GNAT this
-- is picked up from imported variables set by the gcc driver, but
-- for compilers with non-gcc back ends we do it here to allow use
-- of these switches by the front end. Allowed optimization switches
-- are -Os (optimize for size), -O[0123], and -O (same as -O1).
elsif Switch_Chars (First) = 'O' then
if First = Last then
Optimization_Level := 1;
elsif Last - First = 1 then
if Switch_Chars (Last) = 's' then
Optimize_Size := 1;
Optimization_Level := 2; -- Consistent with gcc setting
elsif Switch_Chars (Last) in '0' .. '3' then
Optimization_Level :=
Character'Pos (Switch_Chars (Last)) - Character'Pos ('0');
else
Fail ("invalid switch: " & Switch_Chars);
end if;
else
Fail ("invalid switch: " & Switch_Chars);
end if;
elsif Switch_Chars (First .. Last) = "quiet" then
return; -- ignore this switch
elsif Switch_Chars (First .. Last) = "c" then
return; -- ignore this switch
-- The -x switch and its language name argument will generally be
-- ignored by non-gcc back ends (e.g. the GNAAMP back end). In any
-- case, we save the switch and argument in the compilation switches.
elsif Switch_Chars (First .. Last) = "x" then
Lib.Store_Compilation_Switch (Switch_Chars);
Next_Arg := Next_Arg + 1;
declare
Argv : constant String := Args (Next_Arg).all;
begin
if Is_Switch (Argv) then
Fail ("language name missing after -x");
else
Lib.Store_Compilation_Switch (Argv);
end if;
end;
return;
-- Special check, the back end switch -fno-inline also sets the
-- front end flag to entirely inhibit all inlining. So we store it
-- and set the appropriate flag.
elsif Switch_Chars (First .. Last) = "fno-inline" then
Lib.Store_Compilation_Switch (Switch_Chars);
Opt.Suppress_All_Inlining := True;
return;
-- Similar processing for -fpreserve-control-flow
elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then
Lib.Store_Compilation_Switch (Switch_Chars);
Opt.Suppress_Control_Flow_Optimizations := True;
return;
-- Ignore all other back end switches
elsif Is_Back_End_Switch (Switch_Chars) then
null;
-- Give error for junk switch
else
Fail ("invalid switch: " & Switch_Chars);
end if;
-- Store any other GCC switches
Lib.Store_Compilation_Switch (Switch_Chars);
end Scan_Back_End_Switches;
-- Start of processing for Scan_Compiler_Args
begin
-- Put all the arguments in argument list Args
for Arg in 1 .. Argument_Count loop
declare
Argv : String (1 .. Len_Arg (Arg));
begin
Fill_Arg (Argv'Address, Arg);
Args (Arg) := new String'(Argv);
end;
end loop;
-- Loop through command line arguments, storing them for later access
while Next_Arg <= Argument_Count loop
Look_At_Arg : declare
Argv : constant String := Args (Next_Arg).all;
begin
if Argv'Length = 0 then
Fail ("Empty argument");
end if;
-- If the previous switch has set the Output_File_Name_Present
-- flag (that is we have seen a -gnatO), then the next argument
-- is the name of the output object file.
if Opt.Output_File_Name_Present
and then not Output_File_Name_Seen
then
if Is_Switch (Argv) then
Fail ("Object file name missing after -gnatO");
else
Set_Output_Object_File_Name (Argv);
Output_File_Name_Seen := True;
end if;
-- If the previous switch has set the Search_Directory_Present
-- flag (that is if we have just seen -I), then the next
-- argument is a search directory path.
elsif Search_Directory_Present then
if Is_Switch (Argv) then
Fail ("search directory missing after -I");
else
Add_Src_Search_Dir (Argv);
-- Add directory to lib search so that back-end can take as
-- input ALI files if needed. Otherwise this won't have any
-- impact on the compiler.
Add_Lib_Search_Dir (Argv);
Search_Directory_Present := False;
end if;
-- If not a switch, must be a file name
elsif not Is_Switch (Argv) then
Add_File (Argv);
-- Front end switch
elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv, Args, Next_Arg);
-- All non-front-end switches are back-end switches
else
Scan_Back_End_Switches (Argv);
end if;
end Look_At_Arg;
Next_Arg := Next_Arg + 1;
end loop;
end Scan_Compiler_Arguments;
end Adabkend;

52
gcc/ada/adabkend.ads Normal file
View file

@ -0,0 +1,52 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A B K E N D --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Generic package implementing the common parts of back_end.adb for back ends
-- written in Ada, thereby reducing code duplication.
with Types;
generic
Product_Name : String;
Copyright_Years : String;
with procedure Driver (Root : Types.Node_Id);
-- Main driver procedure for back end
with function Is_Back_End_Switch (Switch : String) return Boolean;
-- Back-end specific function to determine validity of switches
package Adabkend is
procedure Call_Back_End;
-- Call back end, i.e. make call to the Driver passing the root
-- node for this compilation unit.
procedure Scan_Compiler_Arguments;
-- Acquires command-line parameters passed to the compiler and processes
-- them. Calls Scan_Front_End_Switches for any front-end switches
-- encountered. See spec of Back_End for more details.
end Adabkend;