2009-04-20 Thomas Quinot <quinot@adacore.com>
+ * sem_type.adb, ali.adb, erroutc.adb: Minor code reorganization
+ (no behaviour change): Use Append instead of Increment_Last followed
+ by assignment.
+
+2009-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate the
+ declarations of all primitives associated with dispatching asynchronous,
+ conditional and timed selects when dispaching calls are forbidden and
+ select statements are not allowed (such as in Ravenscar).
+ (Predefined_Primitive_Bodies): Ditto for bodies.
+
+ * exp_disp.ad (Make_DT): Do not create and populate the
+ Select_Specific_Data of the dispatch table when dispatching calls are
+ forbidden and select statements are not allowed (such as in Ravenscar).
+
+2009-04-20 Robert Dewar <dewar@adacore.com>
+
+ * a-tifiio.adb: Minor reformatting
+
+2009-04-20 Thomas Quinot <quinot@adacore.com>
+
+ * g-socthi-vms.adb, g-socket.adb, g-socket.ads: inet_aton(3), unlike
+ other C library functions, report *failure* with a zero status, and
+ success with a non-zero status.
+
+2009-04-20 Bob Duff <duff@adacore.com>
+
+ * sem.ads, sem.adb (Walk_Library_Items): New generic procedure.
+ (Semantics): After analyzing each unit, Append it to the
+ Comp_Unit_List, if appropriate.
+
+ * gnat1drv.adb (Check_Library_Items): New procedure for debugging
+ purposes.
+ (Gnat1drv): Correct comment regarding Back_End_Mode.
+
+2009-04-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat_ugn.texi: Add documentation for -fno-inline-small-functions.
+
+2009-04-20 Thomas Quinot <quinot@adacore.com>
+
* s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
output.adb, output.ads, s-taprop-hpux-dce.adb,
s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-posix.adb: Minor
and then Num'Small * 10.0**Scale < 10.0);
Exact : constant Boolean :=
- Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
- or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
- or Num'Small >= 10.0**Max_Digits;
+ Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
+ or Num'Small >= 10.0**Max_Digits;
-- True iff a numerator and denominator can be calculated such that
- -- their ratio exactly represents the small of Num
+ -- their ratio exactly represents the small of Num.
procedure Put
(To : out String;
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
-
begin
Aux.Get (File, Long_Long_Float (Item), Width);
-
exception
when Constraint_Error => raise Data_Error;
end Get;
Width : Field := 0)
is
pragma Unsuppress (Range_Check);
-
begin
Aux.Get (Current_In, Long_Long_Float (Item), Width);
-
exception
when Constraint_Error => raise Data_Error;
end Get;
Last : out Positive)
is
pragma Unsuppress (Range_Check);
-
begin
Aux.Gets (From, Long_Long_Float (Item), Last);
-
exception
when Constraint_Error => raise Data_Error;
end Get;
Aft : Field := Default_Aft;
Exp : Field := Default_Exp)
is
- Fore : constant Integer := To'Length
- - 1 -- Decimal point
- - Field'Max (1, Aft) -- Decimal part
- - Boolean'Pos (Exp /= 0) -- Exponent indicator
- - Exp; -- Exponent
+ Fore : constant Integer :=
+ To'Length
+ - 1 -- Decimal point
+ - Field'Max (1, Aft) -- Decimal part
+ - Boolean'Pos (Exp /= 0) -- Exponent indicator
+ - Exp; -- Exponent
+
Last : Natural;
begin
-- Add C to the output string To, updating Last
procedure Put_Digit (X : Digit);
- -- Add digit X to the output string (going from left to right),
- -- updating Last and Pos, and inserting the sign, leading zeros
- -- or a decimal point when necessary. After outputting the first
- -- digit, Pos must not be changed outside Put_Digit anymore
+ -- Add digit X to the output string (going from left to right), updating
+ -- Last and Pos, and inserting the sign, leading zeros or a decimal
+ -- point when necessary. After outputting the first digit, Pos must not
+ -- be changed outside Put_Digit anymore.
procedure Put_Int64 (X : Int64; Scale : Integer);
- -- Output the decimal number abs X * 10**Scale.
+ -- Output the decimal number abs X * 10**Scale
procedure Put_Scaled
(X, Y, Z : Int64;
begin
if Last = To'First - 1 then
if X /= 0 or Pos <= 0 then
+
-- Before outputting first digit, include leading space,
-- possible minus sign and, if the first digit is fractional,
-- decimal seperator and leading zeros.
-- If and only if more than one digit is output before the decimal
-- point, pos will be unequal to scale when outputting the first
-- digit.
+
pragma Assert (Pos = Scale or else Last = To'First - 1);
Pos := Scale;
pragma Assert (E >= -Max_Digits);
AA : constant Field := E + A;
N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1;
+
Q : array (0 .. N - 1) of Int64 := (others => 0);
- -- Each element of Q has Max_Digits decimal digits, except
- -- the last, which has eAA rem Max_Digits. Only Q (Q'First)
- -- may have an absolute value equal to or larger than 10**Max_Digits.
- -- Only the absolute value of the elements is not significant, not
- -- the sign.
+ -- Each element of Q has Max_Digits decimal digits, except the
+ -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an
+ -- absolute value equal to or larger than 10**Max_Digits. Only the
+ -- absolute value of the elements is not significant, not the sign.
- XX : Int64 := X;
- YY : Int64 := Y;
+ XX : Int64 := X;
+ YY : Int64 := Y;
begin
for J in Q'Range loop
if -E > A then
pragma Assert (N = 1);
- Discard_Extra_Digits :
- declare
+ Discard_Extra_Digits : declare
Factor : constant Int64 := 10**(-E - A);
+
begin
-- The scaling factors were such that the first division
-- produced more digits than requested. So divide away extra
end Discard_Extra_Digits;
end if;
- -- At this point XX is a remainder and we need to determine if
- -- the quotient in Q must be rounded away from zero.
+ -- At this point XX is a remainder and we need to determine if the
+ -- quotient in Q must be rounded away from zero.
+
-- As XX is less than the divisor, it is safe to take its absolute
-- without chance of overflow. The check to see if XX is at least
-- half the absolute value of the divisor must be done carefully to
end if;
loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ Add_Char_To_Name_Buffer (Getc);
exit when At_End_Of_Field and not Ignore_Spaces;
Name_Len := 0;
while not At_Eol loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ Add_Char_To_Name_Buffer (Getc);
end loop;
-- If -fstack-check, record that it occurred
if Nextc not in '0' .. '9' then
Name_Len := 0;
while not At_End_Of_Field loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ Add_Char_To_Name_Buffer (Getc);
end loop;
-- Set the subunit name. Note that we use Name_Find rather
Name_Len := 0;
while not At_End_Of_Field loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
+ Add_Char_To_Name_Buffer (Getc);
end loop;
Sdep.Table (Sdep.Last).Rfile := Name_Enter;
Name_Len := 0;
while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Text (J);
+ Add_Char_To_Name_Buffer (Text (J));
J := J + 1;
end loop;
-- Disp_Timed_Select
-- These operations cannot be implemented on VM targets, so we simply
- -- disable their generation in this case. We also disable generation
- -- of these bodies if No_Dispatching_Calls is active.
+ -- disable their generation in this case. Disable the generation of
+ -- these bodies if No_Dispatching_Calls or Ravenscar is active.
if Ada_Version >= Ada_05
and then VM_Target = No_VM
- and then RTE_Available (RE_Select_Specific_Data)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
-- These primitives are defined abstract in interface types
-- The interface versions will have null bodies
-- These operations cannot be implemented on VM targets, so we simply
- -- disable their generation in this case. We also disable generation
- -- of these bodies if No_Dispatching_Calls is active.
+ -- disable their generation in this case. Disable the generation of
+ -- these bodies if No_Dispatching_Calls or Ravenscar is active.
if Ada_Version >= Ada_05
and then VM_Target = No_VM
- and then not Restriction_Active (No_Dispatching_Calls)
and then not Is_Interface (Tag_Typ)
and then
((Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else (Is_Concurrent_Record_Type (Tag_Typ)
- and then Has_Interfaces (Tag_Typ)))
- and then RTE_Available (RE_Select_Specific_Data)
+ and then Has_Interfaces (Tag_Typ)))
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
Append_To (Result,
Make_Object_Declaration (Loc,
Append_List_To (Result, Elab_Code);
end if;
- -- Populate the two auxiliary tables used for dispatching
- -- asynchronous, conditional and timed selects for synchronized
- -- types that implement a limited interface.
+ -- Populate the two auxiliary tables used for dispatching asynchronous,
+ -- conditional and timed selects for synchronized types that implement
+ -- a limited interface. Skip this step in Ravenscar profile or when
+ -- general dispatching is forbidden.
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
and then Has_Interfaces (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));
-- Reconstruct a Duration value from a Timeval record (seconds and
-- microseconds).
+ procedure Raise_Socket_Error (Error : Integer);
+ -- Raise Socket_Error with an exception message describing the error code
+ -- from errno.
+
procedure Raise_Host_Error (H_Error : Integer);
-- Raise Host_Error exception with message describing error code (note
-- hstrerror seems to be obsolete) from h_errno.
Res := Inet_Aton (To_Chars_Ptr (Img'Unchecked_Access), Addr'Address);
- if Res = Failure then
+ if Res = 0 then
Raise_Socket_Error (SOSC.EINVAL);
end if;
private
- procedure Raise_Socket_Error (Error : Integer);
- -- Raise Socket_Error with an exception message describing the error code
- -- from errno.
-
type Socket_Type is new Integer;
No_Socket : constant Socket_Type := -1;
---------------
-- VMS does not support inet_aton(3), so emulate it here in terms of
- -- inet_addr(3).
+ -- inet_addr(3). Note: unlike other C functions, inet_aton reports
+ -- failure with a 0 return, and success with a non-zero return.
function Inet_Aton
(Cp : C.Strings.chars_ptr;
pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR");
begin
if Cp = Null_Ptr or else Inp = Null_Address then
- Raise_Socket_Error (SOSC.EINVAL);
+ return 0;
end if;
-- Special case for the all-ones broadcast address: this address has the
if String'(Value (Cp)) = "255.255.255.255" then
Conv.To_Pointer (Inp).all := -1;
- return 0;
+ return 1;
end if;
Res := C_Inet_Addr (Cp);
if Res = -1 then
- return Res;
+ return 0;
end if;
Conv.To_Pointer (Inp).all := Res;
- return 0;
+ return 1;
end Inet_Aton;
----------------
-- Called when we are not generating code, to check if -gnatR was requested
-- and if so, explain that we will not be honoring the request.
+ procedure Check_Library_Items;
+ -- For debugging -- checks the behavior of Walk_Library_Items
+
--------------------
-- Check_Bad_Body --
--------------------
end if;
end Check_Rep_Info;
+ -------------------------
+ -- Check_Library_Items --
+ -------------------------
+
+ procedure Check_Library_Items is
+ -- Walk_Library_Items has plenty of assertions, so all we need to do is
+ -- call it.
+
+ procedure Action (Item : Node_Id);
+ -- Action passed to Walk_Library_Items to do nothing
+
+ procedure Action (Item : Node_Id) is
+ begin
+ null;
+ end Action;
+
+ procedure Walk is new Sem.Walk_Library_Items (Action);
+
+ -- Start of processing for Check_Library_Items
+ begin
+ Walk;
+ end Check_Library_Items;
+
-- Start of processing for Gnat1drv
begin
Back_End_Mode := Skip;
end if;
- -- At this stage Call_Back_End is set to indicate if the backend should
- -- be called to generate code. If it is not set, then code generation
- -- has been turned off, even though code was requested by the original
+ -- At this stage Back_End_Mode is set to indicate if the backend should
+ -- be called to generate code. If it is Skip, then code generation has
+ -- been turned off, even though code was requested by the original
-- command. This is not an error from the user point of view, but it is
-- an error from the point of view of the gcc driver, so we must exit
-- with an error status.
Namet.Lock;
Stringt.Lock;
+ Check_Library_Items; -- For debugging
+
-- Here we call the back end to generate the output code
Generating_Code := True;
@item -fno-inline-functions
@cindex @option{-fno-inline-functions} (@command{gcc})
-Suppresses automatic inlining of small subprograms, which is enabled
+Suppresses automatic inlining of simple subprograms, which is enabled
if @option{-O3} is used.
+@item -fno-inline-small-functions
+@cindex @option{-fno-inline-small-functions} (@command{gcc})
+Suppresses automatic inlining of small subprograms, which is enabled
+if @option{-O2} is used.
+
@item -fno-inline-functions-called-once
@cindex @option{-fno-inline-functions-called-once} (@command{gcc})
Suppresses inlining of subprograms local to the unit and called once
with Atree; use Atree;
with Debug; use Debug;
with Debug_A; use Debug_A;
+with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Fname; use Fname;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Nlists; use Nlists;
+with Output; use Output;
with Sem_Attr; use Sem_Attr;
with Sem_Ch2; use Sem_Ch2;
with Sem_Ch3; use Sem_Ch3;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Uintp; use Uintp;
+with Uname; use Uname;
with Unchecked_Deallocation;
-- generic context, it is empty. At the moment, it is only used
-- for avoiding freezing of external references in generics.
+ Comp_Unit_List : Elist_Id := No_Elist;
+ -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
+ -- processed by Semantics, in an appropriate order. Initialized to
+ -- No_Elist, because it's too early to call New_Elmt_List; we will set it
+ -- to New_Elmt_List on first use.
+
+ Ignore_Comp_Units : Boolean := False;
+ -- If True, we suppress appending compilation units onto the
+ -- Comp_Unit_List.
+
-------------
-- Analyze --
-------------
New_Nodes_OK := 0;
end if;
- Do_Analyze;
+ -- Do analysis, and then append the compilation unit onto the
+ -- Comp_Unit_List, if appropriate. This is done after analysis, so if
+ -- this unit depends on some others, they have already been
+ -- appended. We ignore bodies, except for the main unit itself, and
+ -- everything those bodies depend upon.
+
+ if Ignore_Comp_Units then
+ Do_Analyze;
+ pragma Assert (Ignore_Comp_Units); -- still
+
+ elsif Nkind (Unit (Comp_Unit)) in N_Proper_Body
+ and then not In_Extended_Main_Source_Unit (Comp_Unit)
+ then
+ Ignore_Comp_Units := True;
+ Do_Analyze;
+ pragma Assert (Ignore_Comp_Units);
+ Ignore_Comp_Units := False;
+
+ else
+ Do_Analyze;
+ -- pragma Assert (not Ignore_Comp_Units);
+ -- The above assertion is *almost* true. It fails only when a
+ -- subunit with's its parent procedure body, which has no explicit
+ -- spec.
+
+ if No (Comp_Unit_List) then -- Initialize if first time
+ Comp_Unit_List := New_Elmt_List;
+ end if;
+ if not Ignore_Comp_Units then -- See above commented-out Assert
+ Append_Elmt (Comp_Unit, Comp_Unit_List);
+ end if;
+
+ -- Ignore all units after main unit
+
+ if Comp_Unit = Cunit (Main_Unit) then
+ Ignore_Comp_Units := True;
+ end if;
+ end if;
end if;
-- Save indication of dynamic elaboration checks for ALI file
Restore_Opt_Config_Switches (Save_Config_Switches);
Expander_Mode_Restore;
end Semantics;
+
+ ------------------------
+ -- Walk_Library_Items --
+ ------------------------
+
+ procedure Walk_Library_Items is
+ Enable_Output : constant Boolean := False;
+ -- Set to True to print out the items as we go (for debugging)
+
+ procedure Do_Action (CU : Node_Id; Item : Node_Id);
+ -- Calls Action, with some validity checks
+
+ ---------------
+ -- Do_Action --
+ ---------------
+
+ procedure Do_Action (CU : Node_Id; Item : Node_Id) is
+ begin
+ -- This calls Action at the end. All the preceding code is just
+ -- assertions and debugging output.
+
+ case Nkind (Item) is
+ when N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration |
+ N_Package_Declaration |
+ N_Subprogram_Declaration |
+ N_Subprogram_Renaming_Declaration |
+ N_Package_Renaming_Declaration |
+ N_Generic_Function_Renaming_Declaration |
+ N_Generic_Package_Renaming_Declaration |
+ N_Generic_Procedure_Renaming_Declaration =>
+ null; -- Specs are OK
+
+ when N_Package_Body | N_Subprogram_Body =>
+ -- A body must be the main unit
+
+ pragma Assert (CU = Cunit (Main_Unit));
+ null;
+
+ -- All other cases cannot happen
+
+ when N_Function_Instantiation |
+ N_Procedure_Instantiation |
+ N_Package_Instantiation =>
+ pragma Assert (False, "instantiation");
+ null;
+
+ when N_Subunit =>
+ pragma Assert (False, "subunit");
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+
+ if Present (CU) then
+ pragma Assert (Item /= Stand.Standard_Package_Node);
+
+ if Enable_Output then
+ Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU)));
+ Write_Str (", Unit_Number = ");
+ Write_Int (Int (Get_Cunit_Unit_Number (CU)));
+ Write_Str (", ");
+ Write_Str (Node_Kind'Image (Nkind (Item)));
+ if Item /= Original_Node (Item) then
+ Write_Str (", orig = ");
+ Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
+ end if;
+ Write_Eol;
+ end if;
+
+ else -- Must be Standard
+ pragma Assert (Item = Stand.Standard_Package_Node);
+ if Enable_Output then
+ Write_Line ("Standard");
+ end if;
+ end if;
+
+ Action (Item);
+ end Do_Action;
+
+ Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
+
+ -- Start of processing for Walk_Library_Items
+
+ begin
+ if Enable_Output then
+ Write_Line ("Walk_Library_Items:");
+ Indent;
+ end if;
+
+ -- Do Standard first, then walk the Comp_Unit_List
+
+ Do_Action (Empty, Standard_Package_Node);
+
+ while Present (Cur) loop
+ declare
+ CU : constant Node_Id := Node (Cur);
+ N : constant Node_Id := Unit (CU);
+ begin
+ pragma Assert (Nkind (CU) = N_Compilation_Unit);
+
+ case Nkind (N) is
+ -- If it's a body, then ignore it, unless it's an instance (in
+ -- which case we do the spec), or it's the main unit (in which
+ -- case we do it). Note that it could be both.
+
+ when N_Package_Body | N_Subprogram_Body =>
+ declare
+ Entity : Node_Id := N;
+ begin
+ if Nkind (N) = N_Subprogram_Body then
+ Entity := Specification (Entity);
+ end if;
+ Entity := Defining_Unit_Name (Entity);
+ if Nkind (Entity) not in N_Entity then
+ -- Must be N_Defining_Program_Unit_Name
+ Entity := Defining_Identifier (Entity);
+ end if;
+
+ if Is_Generic_Instance (Entity) then
+ Do_Action (CU, Unit (Library_Unit (CU)));
+ end if;
+ end;
+
+ if CU = Cunit (Main_Unit) then
+ -- Must come last
+
+ pragma Assert (No (Next_Elmt (Cur)));
+
+ Do_Action (CU, N);
+ end if;
+
+ -- It's a spec, so just do it
+
+ when others =>
+ Do_Action (CU, N);
+ end case;
+ end;
+
+ Next_Elmt (Cur);
+ end loop;
+
+ if Enable_Output then
+ Outdent;
+ Write_Line ("end Walk_Library_Items.");
+ end if;
+ end Walk_Library_Items;
+
end Sem;
-- is False, then the status of the check can be determined simply by
-- examining Scope_Checks (C), so this routine is not called in that case.
+ generic
+ with procedure Action (Item : Node_Id);
+ procedure Walk_Library_Items;
+ -- Primarily for use by SofCheck Inspector. Must be called after semantic
+ -- analysis (and expansion) are complete. Walks each relevant library item,
+ -- calling Action for each, in an order such that one will not run across
+ -- forward references. Each Item passed to Action is the declaration or
+ -- body of a library unit, including generics and renamings. The first item
+ -- is the N_Package_Declaration node for package Standard. Bodies are not
+ -- included, except for the main unit itself, which always comes last.
+ --
+ -- Item is never a subunit.
+ --
+ -- Item is never an instantiation. Instead, the instance declaration is
+ -- passed, and (if the instantiation is the main unit), the instance body.
+
end Sem;
end loop;
All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
- All_Interp.Increment_Last;
- All_Interp.Table (All_Interp.Last) := No_Interp;
+ All_Interp.Append (No_Interp);
end Add_Entry;
----------------------------
then
All_Interp.Table (All_Interp.Last) :=
(H, Etype (H), Empty);
- All_Interp.Increment_Last;
- All_Interp.Table (All_Interp.Last) := No_Interp;
+ All_Interp.Append (No_Interp);
goto Next_Homograph;
elsif Scope (H) /= Standard_Standard then
Map_Ptr : Int;
begin
- All_Interp.Increment_Last;
- All_Interp.Table (All_Interp.Last) := No_Interp;
+ All_Interp.Append (No_Interp);
Map_Ptr := Headers (Hash (N));
OSDN Git Service
