Commit 276e7ed0 by Arnaud Charlet

[multiple changes]

2011-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.ads, sem_unit.adb (Type_Without_Stream_Operation): determine
	whether a type lacks user-defined Read or Write operations, or has a
	component that lacks them.
	* sem_attr.adb (Check_Stream_Attribute): if restriction
	No_Default_Stream_Attributes is active, verify that all subcomponent
	types of the target have user-defined stream operations, and report
	error otherwise.
	* exp_ch3.adb (Stream_Operqtion_OK): use Type_Without_Stream_Operation.
	* exp_strm.adb: Build_Elementary_Input_Call,
	Build_Elementary_Write_Call): remove checks for restriction
	No_Default_Stream_Attributes, now checked in semantics.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* prj-conf.ads, prj-conf.adb (Do_Autoconf): If there is no --RTS
	switches on the command line, look for all valid --RTS switches in the
	Builder switches and for each language use the first runtime name found
	to invoke gprconfig.
	(Get_Or_Create_Configuration_File): Warn if --RTS is specified on the
	command line and there is no auto-configuration.
	(Runtime_Name_Set_For): New function.

2011-08-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Build_Object_Declarations): Do not generate the
	elaborate initialization expression for variable Abort when processing
	a package body or a declaration.
	(Create_Finalizer): Propagate the package context when creating the
	exception-related variables.
	* exp_ch7.ads (Build_Object_Declarations): New formal parameter
	For_Package along with usage comment.

From-SVN: r177407
parent 19172ae9
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_util.ads, sem_unit.adb (Type_Without_Stream_Operation): determine
whether a type lacks user-defined Read or Write operations, or has a
component that lacks them.
* sem_attr.adb (Check_Stream_Attribute): if restriction
No_Default_Stream_Attributes is active, verify that all subcomponent
types of the target have user-defined stream operations, and report
error otherwise.
* exp_ch3.adb (Stream_Operqtion_OK): use Type_Without_Stream_Operation.
* exp_strm.adb: Build_Elementary_Input_Call,
Build_Elementary_Write_Call): remove checks for restriction
No_Default_Stream_Attributes, now checked in semantics.
2011-08-04 Vincent Celier <celier@adacore.com>
* prj-conf.ads, prj-conf.adb (Do_Autoconf): If there is no --RTS
switches on the command line, look for all valid --RTS switches in the
Builder switches and for each language use the first runtime name found
to invoke gprconfig.
(Get_Or_Create_Configuration_File): Warn if --RTS is specified on the
command line and there is no auto-configuration.
(Runtime_Name_Set_For): New function.
2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Build_Object_Declarations): Do not generate the
elaborate initialization expression for variable Abort when processing
a package body or a declaration.
(Create_Finalizer): Propagate the package context when creating the
exception-related variables.
* exp_ch7.ads (Build_Object_Declarations): New formal parameter
For_Package along with usage comment.
2011-08-04 Arnaud Charlet <charlet@adacore.com> 2011-08-04 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Makefile.in: Clean up targets. * gcc-interface/Makefile.in: Clean up targets.
......
...@@ -8964,58 +8964,6 @@ package body Exp_Ch3 is ...@@ -8964,58 +8964,6 @@ package body Exp_Ch3 is
is is
Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
function Needs_Elementary_Stream_Operation
(T : Entity_Id) return Boolean;
-- AI05-0161 : if the restriction No_Default_Stream_Attributes is active
-- then we can generate stream subprograms for records that have scalar
-- subcomponents only if those subcomponents have user-defined stream
-- subprograms. For elementary types only 'Read and 'Write are needed.
---------------------------------------
-- Needs_Elementary_Stream_Operation --
---------------------------------------
function Needs_Elementary_Stream_Operation
(T : Entity_Id) return Boolean
is
begin
if not Restriction_Active (No_Default_Stream_Attributes) then
return False;
elsif Is_Elementary_Type (T) then
return No (TSS (T, TSS_Stream_Read))
or else No (TSS (T, TSS_Stream_Write));
elsif Is_Array_Type (T) then
return Needs_Elementary_Stream_Operation (Component_Type (T));
elsif Is_Record_Type (T) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (T);
while Present (Comp) loop
if Needs_Elementary_Stream_Operation (Etype (Comp)) then
return True;
end if;
Next_Component (Comp);
end loop;
return False;
end;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
then
return Needs_Elementary_Stream_Operation (Full_View (T));
else
return False;
end if;
end Needs_Elementary_Stream_Operation;
-- Start processing for Stream_Operation_OK
begin begin
-- Special case of a limited type extension: a default implementation -- Special case of a limited type extension: a default implementation
-- of the stream attributes Read or Write exists if that attribute -- of the stream attributes Read or Write exists if that attribute
...@@ -9109,7 +9057,7 @@ package body Exp_Ch3 is ...@@ -9109,7 +9057,7 @@ package body Exp_Ch3 is
and then not Restriction_Active (No_Dispatch) and then not Restriction_Active (No_Dispatch)
and then not No_Run_Time_Mode and then not No_Run_Time_Mode
and then RTE_Available (RE_Tag) and then RTE_Available (RE_Tag)
and then not Needs_Elementary_Stream_Operation (Typ) and then No (Type_Without_Stream_Operation (Typ))
and then RTE_Available (RE_Root_Stream_Type) and then RTE_Available (RE_Root_Stream_Type)
and then not Is_RTE (Typ, RE_Finalization_Collection); and then not Is_RTE (Typ, RE_Finalization_Collection);
end Stream_Operation_OK; end Stream_Operation_OK;
......
...@@ -1558,7 +1558,8 @@ package body Exp_Ch7 is ...@@ -1558,7 +1558,8 @@ package body Exp_Ch7 is
and then Exceptions_OK and then Exceptions_OK
then then
Prepend_List_To (Finalizer_Decls, Prepend_List_To (Finalizer_Decls,
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id)); Build_Object_Declarations
(Loc, Abort_Id, E_Id, Raised_Id, For_Package));
end if; end if;
-- Create the body of the finalizer -- Create the body of the finalizer
...@@ -2926,10 +2927,11 @@ package body Exp_Ch7 is ...@@ -2926,10 +2927,11 @@ package body Exp_Ch7 is
------------------------------- -------------------------------
function Build_Object_Declarations function Build_Object_Declarations
(Loc : Source_Ptr; (Loc : Source_Ptr;
Abort_Id : Entity_Id; Abort_Id : Entity_Id;
E_Id : Entity_Id; E_Id : Entity_Id;
Raised_Id : Entity_Id) return List_Id Raised_Id : Entity_Id;
For_Package : Boolean := False) return List_Id
is is
A_Expr : Node_Id; A_Expr : Node_Id;
E_Decl : Node_Id; E_Decl : Node_Id;
...@@ -2956,8 +2958,12 @@ package body Exp_Ch7 is ...@@ -2956,8 +2958,12 @@ package body Exp_Ch7 is
-- does not include routine Raise_From_Controlled_Operation which is the -- does not include routine Raise_From_Controlled_Operation which is the
-- the sole user of flag Abort. -- the sole user of flag Abort.
-- This is not needed for library-level finalizers as they are called
-- by the environment task and cannot be aborted.
if Abort_Allowed if Abort_Allowed
and then VM_Target = No_VM and then VM_Target = No_VM
and then not For_Package
then then
declare declare
Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
......
...@@ -58,10 +58,11 @@ package Exp_Ch7 is ...@@ -58,10 +58,11 @@ package Exp_Ch7 is
-- the controlling operations. -- the controlling operations.
function Build_Object_Declarations function Build_Object_Declarations
(Loc : Source_Ptr; (Loc : Source_Ptr;
Abort_Id : Entity_Id; Abort_Id : Entity_Id;
E_Id : Entity_Id; E_Id : Entity_Id;
Raised_Id : Entity_Id) return List_Id; Raised_Id : Entity_Id;
For_Package : Boolean := False) return List_Id;
-- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a
-- list containing the object declarations of boolean flag Abort_Id, the -- list containing the object declarations of boolean flag Abort_Id, the
-- exception occurrence E_Id and boolean flag Raised_Id. -- exception occurrence E_Id and boolean flag Raised_Id.
...@@ -70,7 +71,7 @@ package Exp_Ch7 is ...@@ -70,7 +71,7 @@ package Exp_Ch7 is
-- Exception_Identity (Get_Current_Excep.all) = -- Exception_Identity (Get_Current_Excep.all) =
-- Standard'Abort_Signal'Identity; -- Standard'Abort_Signal'Identity;
-- <or> -- <or>
-- Abort_Id : constant Boolean := False; -- no abort -- Abort_Id : constant Boolean := False; -- no abort or For_Package
-- --
-- E_Id : Exception_Occurrence; -- E_Id : Exception_Occurrence;
-- Raised_Id : Boolean := False; -- Raised_Id : Boolean := False;
......
...@@ -25,14 +25,11 @@ ...@@ -25,14 +25,11 @@
with Atree; use Atree; with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Namet; use Namet; with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
with Opt; use Opt; with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux; with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
...@@ -475,18 +472,6 @@ package body Exp_Strm is ...@@ -475,18 +472,6 @@ package body Exp_Strm is
Lib_RE : RE_Id; Lib_RE : RE_Id;
begin begin
Check_Restriction (No_Default_Stream_Attributes, N);
-- Are we sure following messages are issued in -gnatc mode ???
if Restriction_Active (No_Default_Stream_Attributes) then
Error_Msg_NE
("missing user-defined Input for type&", N, Etype (Targ));
if Nkind (Targ) = N_Selected_Component then
Error_Msg_NE
("\which is a component of type&", N, Etype (Prefix (Targ)));
end if;
end if;
-- Check first for Boolean and Character. These are enumeration types, -- Check first for Boolean and Character. These are enumeration types,
-- but we treat them specially, since they may require special handling -- but we treat them specially, since they may require special handling
...@@ -696,16 +681,6 @@ package body Exp_Strm is ...@@ -696,16 +681,6 @@ package body Exp_Strm is
Libent : Entity_Id; Libent : Entity_Id;
begin begin
Check_Restriction (No_Default_Stream_Attributes, N);
if Restriction_Active (No_Default_Stream_Attributes) then
Error_Msg_NE
("missing user-defined Write for type&", N, Etype (Item));
if Nkind (Item) = N_Selected_Component then
Error_Msg_NE
("\which is a component of type&", N, Etype (Prefix (Item)));
end if;
end if;
-- Compute the size of the stream element. This is either the size of -- Compute the size of the stream element. This is either the size of
-- the first subtype or if given the size of the Stream_Size attribute. -- the first subtype or if given the size of the Stream_Size attribute.
......
...@@ -921,10 +921,10 @@ package body Prj.Conf is ...@@ -921,10 +921,10 @@ package body Prj.Conf is
end loop; end loop;
declare declare
Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
Switches : Argument_List_Access := Get_Config_Switches; Config_Switches : Argument_List_Access;
Args : Argument_List (1 .. 5); Args : Argument_List (1 .. 5);
Arg_Last : Positive; Arg_Last : Positive;
Obj_Dir_Exists : Boolean := True; Obj_Dir_Exists : Boolean := True;
...@@ -968,6 +968,104 @@ package body Prj.Conf is ...@@ -968,6 +968,104 @@ package body Prj.Conf is
end case; end case;
end if; end if;
-- If no switch --RTS have been specified on the command line,
-- look for --RTS switches in the Builder switches.
if RTS_Languages.Get_First = No_Name then
declare
Builder : constant Package_Id :=
Value_Of (Name_Builder, Project.Decl.Packages, Shared);
Switch_Array_Id : Array_Element_Id;
Switch_Array : Array_Element;
Switch_List : String_List_Id := Nil_String;
Switch : String_Element;
Lang : Name_Id;
Lang_Last : Positive;
begin
if Builder /= No_Package then
Switch_Array_Id :=
Value_Of
(Name => Name_Switches,
In_Arrays =>
Shared.Packages.Table (Builder).Decl.Arrays,
Shared => Shared);
while Switch_Array_Id /= No_Array_Element loop
Switch_Array :=
Shared.Array_Elements.Table (Switch_Array_Id);
Switch_List := Switch_Array.Value.Values;
while Switch_List /= Nil_String loop
Switch :=
Shared.String_Elements.Table (Switch_List);
if Switch.Value /= No_Name then
Get_Name_String (Switch.Value);
if Name_Len >= 7 and then
Name_Buffer (1 .. 5) = "--RTS"
then
if Name_Buffer (6) = '=' then
if not Runtime_Name_Set_For (Name_Ada) then
Set_Runtime_For
(Name_Ada,
Name_Buffer (7 .. Name_Len));
end if;
elsif Name_Len > 7 and then
Name_Buffer (6) = ':' and then
Name_Buffer (7) /= '='
then
Lang_Last := 7;
while Lang_Last < Name_Len and then
Name_Buffer (Lang_Last + 1) /= '='
loop
Lang_Last := Lang_Last + 1;
end loop;
if
Name_Buffer (Lang_Last + 1) = '='
then
declare
RTS : constant String :=
Name_Buffer (Lang_Last + 2 ..
Name_Len);
begin
Name_Buffer (1 .. Lang_Last - 6)
:= Name_Buffer (7 .. Lang_Last);
Name_Len := Lang_Last - 6;
To_Lower
(Name_Buffer (1 .. Name_Len));
Lang := Name_Find;
if
not Runtime_Name_Set_For (Lang)
then
Set_Runtime_For (Lang, RTS);
end if;
end;
end if;
end if;
end if;
end if;
Switch_List := Switch.Next;
end loop;
Switch_Array_Id := Switch_Array.Next;
end loop;
end if;
end;
end if;
-- Get the config switches. This should be done only now, as some
-- runtimes may have been found if the Builder switches.
Config_Switches := Get_Config_Switches;
-- Invoke gprconfig -- Invoke gprconfig
Args (1) := new String'("--batch"); Args (1) := new String'("--batch");
...@@ -1041,9 +1139,9 @@ package body Prj.Conf is ...@@ -1041,9 +1139,9 @@ package body Prj.Conf is
Write_Str (Args (J).all); Write_Str (Args (J).all);
end loop; end loop;
for J in Switches'Range loop for J in Config_Switches'Range loop
Write_Char (' '); Write_Char (' ');
Write_Str (Switches (J).all); Write_Str (Config_Switches (J).all);
end loop; end loop;
Write_Eol; Write_Eol;
...@@ -1061,10 +1159,11 @@ package body Prj.Conf is ...@@ -1061,10 +1159,11 @@ package body Prj.Conf is
end if; end if;
end if; end if;
Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all, Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
Config_Switches.all,
Success); Success);
Free (Switches); Free (Config_Switches);
Config_File_Path := Locate_Config_File (Args (3).all); Config_File_Path := Locate_Config_File (Args (3).all);
...@@ -1122,6 +1221,15 @@ package body Prj.Conf is ...@@ -1122,6 +1221,15 @@ package body Prj.Conf is
Do_Autoconf; Do_Autoconf;
end if; end if;
-- If the config file is not auto-generated, warn if there is any --RTS
-- switch on the command line.
elsif RTS_Languages.Get_First /= No_Name and then
Opt.Warning_Mode /= Opt.Suppress
then
Write_Line
("warning: --RTS is taken into account only in auto-configuration");
end if; end if;
-- Parse the configuration file -- Parse the configuration file
...@@ -1405,6 +1513,15 @@ package body Prj.Conf is ...@@ -1405,6 +1513,15 @@ package body Prj.Conf is
end if; end if;
end Runtime_Name_For; end Runtime_Name_For;
--------------------------
-- Runtime_Name_Set_For --
--------------------------
function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
begin
return RTS_Languages.Get (Language) /= No_Name;
end Runtime_Name_Set_For;
--------------------- ---------------------
-- Set_Runtime_For -- -- Set_Runtime_For --
--------------------- ---------------------
......
...@@ -186,4 +186,7 @@ package Prj.Conf is ...@@ -186,4 +186,7 @@ package Prj.Conf is
-- Returns the runtime name for a language. Returns an empty string if no -- Returns the runtime name for a language. Returns an empty string if no
-- runtime was specified for the language using option --RTS. -- runtime was specified for the language using option --RTS.
function Runtime_Name_Set_For (Language : Name_Id) return Boolean;
-- Returns True only of Set_Runtime_For has been called for the Language
end Prj.Conf; end Prj.Conf;
...@@ -1633,6 +1633,39 @@ package body Sem_Attr is ...@@ -1633,6 +1633,39 @@ package body Sem_Attr is
Check_Restriction (No_Streams, P); Check_Restriction (No_Streams, P);
end if; end if;
-- AI05-0057: if restriction No_Default_Stream_Attributes is active,
-- it is illegal to use a predefined elementary type stream attribute
-- either by itself, or more importantly as part of the attribute
-- subprogram for a composite type.
if Restriction_Active (No_Default_Stream_Attributes) then
declare
T : Entity_Id;
begin
if Nam = TSS_Stream_Input
or else Nam = TSS_Stream_Read
then
T :=
Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
else
T :=
Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
end if;
if Present (T) then
Check_Restriction (No_Default_Stream_Attributes, N);
Error_Msg_NE
("missing user-defined Stream Read or Write for type&",
N, T);
if not Is_Elementary_Type (P_Type) then
Error_Msg_NE
("\which is a component of type&", N, P_Type);
end if;
end if;
end;
end if;
-- Check special case of Exception_Id and Exception_Occurrence which -- Check special case of Exception_Id and Exception_Occurrence which
-- are not allowed for restriction No_Exception_Registration. -- are not allowed for restriction No_Exception_Registration.
......
...@@ -31,7 +31,6 @@ with Errout; use Errout; ...@@ -31,7 +31,6 @@ with Errout; use Errout;
with Elists; use Elists; with Elists; use Elists;
with Exp_Ch11; use Exp_Ch11; with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp; with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Fname; use Fname; with Fname; use Fname;
with Freeze; use Freeze; with Freeze; use Freeze;
...@@ -10784,7 +10783,9 @@ package body Sem_Util is ...@@ -10784,7 +10783,9 @@ package body Sem_Util is
elsif Is_Record_Type (Btype) then elsif Is_Record_Type (Btype) then
Component := First_Entity (Btype); Component := First_Entity (Btype);
while Present (Component) loop while Present (Component)
and then Comes_From_Source (Component)
loop
-- Skip anonymous types generated by constrained components -- Skip anonymous types generated by constrained components
...@@ -12229,6 +12230,69 @@ package body Sem_Util is ...@@ -12229,6 +12230,69 @@ package body Sem_Util is
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level; end Type_Access_Level;
------------------------------------
-- Type_Without_Stream_Operation --
------------------------------------
function Type_Without_Stream_Operation
(T : Entity_Id; Op : TSS_Name_Type := TSS_Null) return Entity_Id
is
BT : constant Entity_Id := Base_Type (T);
Op_Missing : Boolean;
begin
if not Restriction_Active (No_Default_Stream_Attributes) then
return Empty;
end if;
if Is_Elementary_Type (T) then
if Op = TSS_Null then
Op_Missing :=
No (TSS (BT, TSS_Stream_Read))
or else No (TSS (BT, TSS_Stream_Write));
else
Op_Missing := No (TSS (BT, Op));
end if;
if Op_Missing then
return T;
else
return Empty;
end if;
elsif Is_Array_Type (T) then
return Type_Without_Stream_Operation (Component_Type (T), Op);
elsif Is_Record_Type (T) then
declare
Comp : Entity_Id;
C_Typ : Entity_Id;
begin
Comp := First_Component (T);
while Present (Comp) loop
C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
if Present (C_Typ) then
return C_Typ;
end if;
Next_Component (Comp);
end loop;
return Empty;
end;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
then
return Type_Without_Stream_Operation (Full_View (T), Op);
else
return Empty;
end if;
end Type_Without_Stream_Operation;
---------------------------- ----------------------------
-- Unique_Defining_Entity -- -- Unique_Defining_Entity --
---------------------------- ----------------------------
......
...@@ -26,6 +26,7 @@ ...@@ -26,6 +26,7 @@
-- Package containing utility procedures used throughout the semantics -- Package containing utility procedures used throughout the semantics
with Einfo; use Einfo; with Einfo; use Einfo;
with Exp_Tss; use Exp_Tss;
with Namet; use Namet; with Namet; use Namet;
with Nmake; use Nmake; with Nmake; use Nmake;
with Snames; use Snames; with Snames; use Snames;
...@@ -1377,6 +1378,16 @@ package Sem_Util is ...@@ -1377,6 +1378,16 @@ package Sem_Util is
function Type_Access_Level (Typ : Entity_Id) return Uint; function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ -- Return the accessibility level of Typ
function Type_Without_Stream_Operation
(T : Entity_Id; Op : TSS_Name_Type := TSS_Null) return Entity_Id;
-- AI05-0161 : if the restriction No_Default_Stream_Attributes is active
-- then we cannot generate stream subprograms for composite types with
-- elementary subcomponents that lack user-defined stream subprograms.
-- This predicate determines whether a type has such an elementary
-- subcomponent. If Op is TSS_Null, a type that lacks either Read or Write
-- prevents the construction of a composite stream operation. If Op is
-- specified we check only for the given stream operation.
function Unique_Defining_Entity (N : Node_Id) return Entity_Id; function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that matching -- Return the entity which represents declaration N, so that matching
-- declaration and body have the same entity. -- declaration and body have the same entity.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment