+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * frontend.adb: Remove call to initialize Exp_Ch6.
+ * exp_ch6.ads, exp_ch6.adb (Initialize): removed.
+ (Unest_Entry/Unest_Bodies): Removed.
+ (Unnest_Subprograms): Code cleanup.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * set_targ.adb (Read_Target_Dependent_Values):
+ close target description file once its contents is read.
+ * s-os_lib.adb (Non_Blocking_Spawn, version with Stdout_File
+ and Stderr_File): Close local file descriptors before spawning
+ child process.
+ * exp_util.adb (Containing_Package_With_Ext_Axioms): Limit scope of
+ local variables to make the code easier to understand and avoid
+ duplicated calls to Parent and Generic_Parent.
+
2016-04-20 Bob Duff <duff@adacore.com>
* s-os_lib.ads: Minor comment fix.
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Ch6 is
- -------------------------------------
- -- Table for Unnesting Subprograms --
- -------------------------------------
-
- -- When we expand a subprogram body, if it has nested subprograms and if
- -- we are in Unnest_Subprogram_Mode, then we record the subprogram entity
- -- and the body in this table, to later be passed to Unnest_Subprogram.
-
- -- We need this delaying mechanism, because we have to wait until all
- -- instantiated bodies have been inserted before doing the unnesting.
-
- type Unest_Entry is record
- Ent : Entity_Id;
- -- Entity for subprogram to be unnested
-
- Bod : Node_Id;
- -- Subprogram body to be unnested
- end record;
-
- package Unest_Bodies is new Table.Table (
- Table_Component_Type => Unest_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "Unest_Bodies");
-
-----------------------
-- Local Subprograms --
-----------------------
return False;
end Has_Unconstrained_Access_Discriminants;
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Unest_Bodies.Init;
- end Initialize;
-
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
procedure Unnest_Subprograms (N : Node_Id) is
- procedure Search_Unnesting_Subprograms (N : Node_Id);
- -- Search for outer level procedures with nested subprograms and append
- -- them to the Unnest table.
+ function Search_Subprograms (N : Node_Id) return Traverse_Result;
+ -- Tree visitor that search for outer level procedures with nested
+ -- subprograms and invokes Unnest_Subprogram()
- ----------------------------------
- -- Search_Unnesting_Subprograms --
- ----------------------------------
-
- procedure Search_Unnesting_Subprograms (N : Node_Id) is
-
- function Search_Subprograms (N : Node_Id) return Traverse_Result;
- -- Tree visitor that search for outer level procedures with nested
- -- subprograms and adds them to the Unnest table.
-
- ------------------------
- -- Search_Subprograms --
- ------------------------
-
- function Search_Subprograms (N : Node_Id) return Traverse_Result is
- begin
- if Nkind_In (N, N_Subprogram_Body,
- N_Subprogram_Body_Stub)
- then
- declare
- Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
-
- begin
- -- We are only interested in subprograms (not generic
- -- subprograms), that have nested subprograms.
+ ------------------------
+ -- Search_Subprograms --
+ ------------------------
- if Is_Subprogram (Spec_Id)
- and then Has_Nested_Subprogram (Spec_Id)
- and then Is_Library_Level_Entity (Spec_Id)
- then
- Unest_Bodies.Append ((Spec_Id, N));
- end if;
- end;
- end if;
+ function Search_Subprograms (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (N, N_Subprogram_Body,
+ N_Subprogram_Body_Stub)
+ then
+ declare
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
- return OK;
- end Search_Subprograms;
+ begin
+ -- We are only interested in subprograms (not generic
+ -- subprograms), that have nested subprograms.
- ---------------
- -- Do_Search --
- ---------------
+ if Is_Subprogram (Spec_Id)
+ and then Has_Nested_Subprogram (Spec_Id)
+ and then Is_Library_Level_Entity (Spec_Id)
+ then
+ Unnest_Subprogram (Spec_Id, N);
+ end if;
+ end;
+ end if;
- procedure Do_Search is new Traverse_Proc (Search_Subprograms);
- -- Subtree visitor instantiation
+ return OK;
+ end Search_Subprograms;
- -- Start of processing for Search_Unnesting_Subprograms
+ ---------------
+ -- Do_Search --
+ ---------------
- begin
- if Opt.Unnest_Subprogram_Mode then
- Do_Search (N);
- end if;
- end Search_Unnesting_Subprograms;
+ procedure Do_Search is new Traverse_Proc (Search_Subprograms);
+ -- Subtree visitor instantiation
-- Start of processing for Unnest_Subprograms
return;
end if;
- Search_Unnesting_Subprograms (N);
-
- for J in Unest_Bodies.First .. Unest_Bodies.Last loop
- declare
- UBJ : Unest_Entry renames Unest_Bodies.Table (J);
- begin
- Unnest_Subprogram (UBJ.Ent, UBJ.Bod);
- end;
- end loop;
+ Do_Search (N);
end Unnest_Subprograms;
end Exp_Ch6;
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
- procedure Initialize;
- -- Initialize internal tables
-
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- function, or access-to-function type whose result must be built in
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
----------------------------------------
function Containing_Package_With_Ext_Axioms
- (E : Entity_Id) return Entity_Id
- is
- Decl : Node_Id;
- First_Ax_Parent_Scope : Entity_Id;
-
+ (E : Entity_Id) return Entity_Id is
begin
-- E is the package or generic package which is externally axiomatized
-- If E's scope is axiomatized, E is axiomatized
if Present (Scope (E)) then
- First_Ax_Parent_Scope :=
- Containing_Package_With_Ext_Axioms (Scope (E));
-
- if Present (First_Ax_Parent_Scope) then
- return First_Ax_Parent_Scope;
- end if;
-
+ declare
+ First_Ax_Parent_Scope : constant Entity_Id :=
+ Containing_Package_With_Ext_Axioms (Scope (E));
+ begin
+ if Present (First_Ax_Parent_Scope) then
+ return First_Ax_Parent_Scope;
+ end if;
+ end;
end if;
-- Otherwise, if E is a package instance, it is axiomatized if the
-- corresponding generic package is axiomatized.
if Ekind (E) = E_Package then
- if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
- Decl := Parent (Parent (E));
- else
- Decl := Parent (E);
- end if;
+ declare
+ Par : constant Node_Id := Parent (E);
+ Decl : Node_Id;
+ begin
+ if Nkind (Par) = N_Defining_Program_Unit_Name then
+ Decl := Parent (Par);
+ else
+ Decl := Par;
+ end if;
- if Present (Generic_Parent (Decl)) then
- return
- Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
- end if;
+ if Present (Generic_Parent (Decl)) then
+ return
+ Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
+ end if;
+ end;
end if;
return Empty;
Checks.Initialize;
Sem_Warn.Initialize;
Prep.Initialize;
- Exp_Ch6.Initialize;
if Generate_SCIL then
SCIL_LL.Initialize;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2015, AdaCore --
+-- Copyright (C) 1995-2016, 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- --
Saved_Error : File_Descriptor;
Saved_Output : File_Descriptor;
+ Dummy_Status : Boolean;
+
begin
-- Do not attempt to spawn if the output files could not be created
Saved_Error := Dup (Standerr);
Dup2 (Stderr_FD, Standerr);
- -- Spawn the program
-
- Result := Non_Blocking_Spawn (Program_Name, Args);
+ Set_Close_On_Exec (Saved_Output, True, Dummy_Status);
+ Set_Close_On_Exec (Saved_Error, True, Dummy_Status);
-- Close the files just created for the output, as the file descriptors
-- cannot be used anywhere, being local values. It is safe to do that,
Close (Stdout_FD);
Close (Stderr_FD);
+ -- Spawn the program
+
+ Result := Non_Blocking_Spawn (Program_Name, Args);
+
-- Restore the standard output and error
Dup2 (Saved_Output, Standout);
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2016, 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- --
Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
+ Close (File_Desc);
+
if Buflen = Buffer'Length then
Fail ("file is too long: " & File_Name);
end if;
projects / gcc.git / commitdiff