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>
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / gcc.git / commitdiff