Skip to content

R
riscv-gcc-1
Commit d9f8616e by Arnaud Charlet
Options

[multiple changes] 

2013-04-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Pragma, (Check_Mode_Restriction_In_Function):
	Correct error message format.

2013-04-12  Robert Dewar  <dewar@adacore.com>

	* sem_attr.adb: Minor reformatting.

2013-04-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.adb (Within_Elaborate_All): Do not examine a context
	item that has not been analyzed, because the unit may have errors,
	or the context item may come from a proper unit inserted at the
	point of a stub and not analyzed yet.

2013-04-12  Thomas Quinot  <quinot@adacore.com>

	* gnat1drv.adb, repinfo.adb, repinfo.ads (Repinfo.List_Array_Info,
	List_Record_Info): Also include scalar storage order information in
	output.

2013-04-12  Yannick Moy  <moy@adacore.com>

	* sem_ch6.adb (Process_Contract_Cases): Update code to apply to
	Contract_Cases instead of Contract_Case pragma.

From-SVN: r197906
parent 2eb87017
Showing with 152 additions and 60 deletions
gcc/ada/ChangeLog
2013-04-12 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Pragma, (Check_Mode_Restriction_In_Function):
Correct error message format.
2013-04-12 Robert Dewar <dewar@adacore.com>
* sem_attr.adb: Minor reformatting.
2013-04-12 Ed Schonberg <schonberg@adacore.com>
* sem_elab.adb (Within_Elaborate_All): Do not examine a context
item that has not been analyzed, because the unit may have errors,
or the context item may come from a proper unit inserted at the
point of a stub and not analyzed yet.
2013-04-12 Thomas Quinot <quinot@adacore.com>
* gnat1drv.adb, repinfo.adb, repinfo.ads (Repinfo.List_Array_Info,
List_Record_Info): Also include scalar storage order information in
output.
2013-04-12 Yannick Moy <moy@adacore.com>
* sem_ch6.adb (Process_Contract_Cases): Update code to apply to
Contract_Cases instead of Contract_Case pragma.
2013-04-12 Robert Dewar <dewar@adacore.com> 2013-04-12 Robert Dewar <dewar@adacore.com>
* a-cfdlli.ads, g-socket.adb, s-fileio.adb: Minor reformatting. * a-cfdlli.ads, g-socket.adb, s-fileio.adb: Minor reformatting.
......
gcc/ada/gnat1drv.adb
...@@ -1259,7 +1259,7 @@ begin ...@@ -1259,7 +1259,7 @@ begin
Errout.Finalize (Last_Call => True); Errout.Finalize (Last_Call => True);
Errout.Output_Messages; Errout.Output_Messages;
List_Rep_Info; List_Rep_Info (Ttypes.Bytes_Big_Endian);
List_Inlining_Info; List_Inlining_Info;
-- Only write the library if the backend did not generate any error -- Only write the library if the backend did not generate any error
......
gcc/ada/repinfo.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,6 +38,7 @@ with Lib; use Lib; ...@@ -38,6 +38,7 @@ with Lib; use Lib;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Output; use Output; with Output; use Output;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
...@@ -133,7 +134,7 @@ package body Repinfo is ...@@ -133,7 +134,7 @@ package body Repinfo is
-- Called before outputting anything for an entity. Ensures that -- Called before outputting anything for an entity. Ensures that
-- a blank line precedes the output for a particular entity. -- a blank line precedes the output for a particular entity.
procedure List_Entities (Ent : Entity_Id); procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
-- This procedure lists the entities associated with the entity E, starting -- This procedure lists the entities associated with the entity E, starting
-- with the First_Entity and using the Next_Entity link. If a nested -- with the First_Entity and using the Next_Entity link. If a nested
-- package is found, entities within the package are recursively processed. -- package is found, entities within the package are recursively processed.
...@@ -142,7 +143,7 @@ package body Repinfo is ...@@ -142,7 +143,7 @@ package body Repinfo is
-- List name of entity Ent in appropriate case. The name is listed with -- List name of entity Ent in appropriate case. The name is listed with
-- full qualification up to but not including the compilation unit name. -- full qualification up to but not including the compilation unit name.
procedure List_Array_Info (Ent : Entity_Id); procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
-- List representation info for array type Ent -- List representation info for array type Ent
procedure List_Mechanisms (Ent : Entity_Id); procedure List_Mechanisms (Ent : Entity_Id);
...@@ -152,9 +153,14 @@ package body Repinfo is ...@@ -152,9 +153,14 @@ package body Repinfo is
procedure List_Object_Info (Ent : Entity_Id); procedure List_Object_Info (Ent : Entity_Id);
-- List representation info for object Ent -- List representation info for object Ent
procedure List_Record_Info (Ent : Entity_Id); procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
-- List representation info for record type Ent -- List representation info for record type Ent
procedure List_Scalar_Storage_Order
(Ent : Entity_Id;
Bytes_Big_Endian : Boolean);
-- List scalar storage order information for record or array type Ent
procedure List_Type_Info (Ent : Entity_Id); procedure List_Type_Info (Ent : Entity_Id);
-- List type info for type Ent -- List type info for type Ent
...@@ -286,7 +292,7 @@ package body Repinfo is ...@@ -286,7 +292,7 @@ package body Repinfo is
-- List_Array_Info -- -- List_Array_Info --
---------------------- ----------------------
procedure List_Array_Info (Ent : Entity_Id) is procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
begin begin
List_Type_Info (Ent); List_Type_Info (Ent);
Write_Str ("for "); Write_Str ("for ");
...@@ -294,13 +300,15 @@ package body Repinfo is ...@@ -294,13 +300,15 @@ package body Repinfo is
Write_Str ("'Component_Size use "); Write_Str ("'Component_Size use ");
Write_Val (Component_Size (Ent)); Write_Val (Component_Size (Ent));
Write_Line (";"); Write_Line (";");
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
end List_Array_Info; end List_Array_Info;
------------------- -------------------
-- List_Entities -- -- List_Entities --
------------------- -------------------
procedure List_Entities (Ent : Entity_Id) is procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
Body_E : Entity_Id; Body_E : Entity_Id;
E : Entity_Id; E : Entity_Id;
...@@ -379,12 +387,12 @@ package body Repinfo is ...@@ -379,12 +387,12 @@ package body Repinfo is
elsif Is_Record_Type (E) then elsif Is_Record_Type (E) then
if List_Representation_Info >= 1 then if List_Representation_Info >= 1 then
List_Record_Info (E); List_Record_Info (E, Bytes_Big_Endian);
end if; end if;
elsif Is_Array_Type (E) then elsif Is_Array_Type (E) then
if List_Representation_Info >= 1 then if List_Representation_Info >= 1 then
List_Array_Info (E); List_Array_Info (E, Bytes_Big_Endian);
end if; end if;
elsif Is_Type (E) then elsif Is_Type (E) then
...@@ -411,7 +419,7 @@ package body Repinfo is ...@@ -411,7 +419,7 @@ package body Repinfo is
if Ekind (E) = E_Package then if Ekind (E) = E_Package then
if No (Renamed_Object (E)) then if No (Renamed_Object (E)) then
List_Entities (E); List_Entities (E, Bytes_Big_Endian);
end if; end if;
-- Recurse into bodies -- Recurse into bodies
...@@ -428,12 +436,12 @@ package body Repinfo is ...@@ -428,12 +436,12 @@ package body Repinfo is
or else or else
Ekind (E) = E_Protected_Body Ekind (E) = E_Protected_Body
then then
List_Entities (E); List_Entities (E, Bytes_Big_Endian);
-- Recurse into blocks -- Recurse into blocks
elsif Ekind (E) = E_Block then elsif Ekind (E) = E_Block then
List_Entities (E); List_Entities (E, Bytes_Big_Endian);
end if; end if;
end if; end if;
...@@ -461,7 +469,7 @@ package body Repinfo is ...@@ -461,7 +469,7 @@ package body Repinfo is
and then and then
Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
then then
List_Entities (Body_E); List_Entities (Body_E, Bytes_Big_Endian);
end if; end if;
end if; end if;
...@@ -779,7 +787,7 @@ package body Repinfo is ...@@ -779,7 +787,7 @@ package body Repinfo is
-- List_Record_Info -- -- List_Record_Info --
---------------------- ----------------------
procedure List_Record_Info (Ent : Entity_Id) is procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
Comp : Entity_Id; Comp : Entity_Id;
Cfbit : Uint; Cfbit : Uint;
Sunit : Uint; Sunit : Uint;
...@@ -963,13 +971,15 @@ package body Repinfo is ...@@ -963,13 +971,15 @@ package body Repinfo is
end loop; end loop;
Write_Line ("end record;"); Write_Line ("end record;");
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
end List_Record_Info; end List_Record_Info;
------------------- -------------------
-- List_Rep_Info -- -- List_Rep_Info --
------------------- -------------------
procedure List_Rep_Info is procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
Col : Nat; Col : Nat;
begin begin
...@@ -994,7 +1004,7 @@ package body Repinfo is ...@@ -994,7 +1004,7 @@ package body Repinfo is
end loop; end loop;
Write_Eol; Write_Eol;
List_Entities (Cunit_Entity (U)); List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
-- List representation information to file -- List representation information to file
...@@ -1002,7 +1012,7 @@ package body Repinfo is ...@@ -1002,7 +1012,7 @@ package body Repinfo is
Create_Repinfo_File_Access.all Create_Repinfo_File_Access.all
(Get_Name_String (File_Name (Source_Index (U)))); (Get_Name_String (File_Name (Source_Index (U))));
Set_Special_Output (Write_Info_Line'Access); Set_Special_Output (Write_Info_Line'Access);
List_Entities (Cunit_Entity (U)); List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
Set_Special_Output (null); Set_Special_Output (null);
Close_Repinfo_File_Access.all; Close_Repinfo_File_Access.all;
end if; end if;
...@@ -1011,6 +1021,49 @@ package body Repinfo is ...@@ -1011,6 +1021,49 @@ package body Repinfo is
end if; end if;
end List_Rep_Info; end List_Rep_Info;
-------------------------------
-- List_Scalar_Storage_Order --
-------------------------------
procedure List_Scalar_Storage_Order
(Ent : Entity_Id;
Bytes_Big_Endian : Boolean)
is
procedure List_Attr (Attr_Name : String);
-- Show attribute definition clause for Attr_Name
---------------
-- List_Attr --
---------------
procedure List_Attr (Attr_Name : String) is
begin
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'" & Attr_Name & " use System.");
if Bytes_Big_Endian xor Reverse_Storage_Order (Ent) then
Write_Str ("High");
else
Write_Str ("Low");
end if;
Write_Line ("_Order_First;");
end List_Attr;
-- Start of processing for List_Scalar_Storage_Order
begin
if Has_Rep_Item (Ent, Name_Scalar_Storage_Order) then
-- For a record type with explicitly specified scalar storage order,
-- also display explicit Bit_Order.
if Is_Record_Type (Ent) then
List_Attr ("Bit_Order");
end if;
List_Attr ("Scalar_Storage_Order");
end if;
end List_Scalar_Storage_Order;
-------------------- --------------------
-- List_Type_Info -- -- List_Type_Info --
-------------------- --------------------
......
gcc/ada/repinfo.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -283,8 +283,9 @@ package Repinfo is ...@@ -283,8 +283,9 @@ package Repinfo is
-- Compiler Interface -- -- Compiler Interface --
------------------------ ------------------------
procedure List_Rep_Info; procedure List_Rep_Info (Bytes_Big_Endian : Boolean);
-- Procedure to list representation information -- Procedure to list representation information. Bytes_Big_Endian is the
-- value from Ttypes (Repinfo cannot have a dependency on Ttypes).
procedure Tree_Write; procedure Tree_Write;
-- Writes out internal tables to current tree file using the relevant -- Writes out internal tables to current tree file using the relevant
......
gcc/ada/sem_attr.adb
...@@ -4314,8 +4314,8 @@ package body Sem_Attr is ...@@ -4314,8 +4314,8 @@ package body Sem_Attr is
Arg := Parent (Arg); Arg := Parent (Arg);
end loop; end loop;
-- At this point, Parent (Arg) should be a -- At this point, Parent (Arg) should be a component
-- N_Component_Association. Attribute Old is only allowed in -- association. Attribute Result is only allowed in
-- the expression part of this association. -- the expression part of this association.
if Nkind (Parent (Arg)) /= N_Component_Association if Nkind (Parent (Arg)) /= N_Component_Association
...@@ -4731,9 +4731,9 @@ package body Sem_Attr is ...@@ -4731,9 +4731,9 @@ package body Sem_Attr is
Arg := Parent (Arg); Arg := Parent (Arg);
end loop; end loop;
-- At this point, Parent (Arg) should be a -- At this point, Parent (Arg) should be a component
-- N_Component_Association. Attribute Result is only -- association. Attribute Result is only allowed in
-- allowed in the expression part of this association. -- the expression part of this association.
if Nkind (Parent (Arg)) /= N_Component_Association if Nkind (Parent (Arg)) /= N_Component_Association
or else Arg /= Expression (Parent (Arg)) or else Arg /= Expression (Parent (Arg))
......
gcc/ada/sem_ch6.adb
...@@ -7064,8 +7064,8 @@ package body Sem_Ch6 is ...@@ -7064,8 +7064,8 @@ package body Sem_Ch6 is
-- Last non-trivial postcondition on the subprogram, or else Empty if -- Last non-trivial postcondition on the subprogram, or else Empty if
-- either no non-trivial postcondition or only inherited postconditions. -- either no non-trivial postcondition or only inherited postconditions.
Last_Contract_Case : Node_Id := Empty; Last_Contract_Cases : Node_Id := Empty;
-- Last non-trivial contract-case on the subprogram, or else Empty -- Last non-trivial contract-cases on the subprogram, or else Empty
Attribute_Result_Mentioned : Boolean := False; Attribute_Result_Mentioned : Boolean := False;
-- Whether attribute 'Result is mentioned in a non-trivial postcondition -- Whether attribute 'Result is mentioned in a non-trivial postcondition
...@@ -7205,7 +7205,9 @@ package body Sem_Ch6 is ...@@ -7205,7 +7205,9 @@ package body Sem_Ch6 is
procedure Process_Contract_Cases (Spec : Node_Id) is procedure Process_Contract_Cases (Spec : Node_Id) is
Prag : Node_Id; Prag : Node_Id;
Arg : Node_Id; Aggr : Node_Id;
Conseq : Node_Id;
Post_Case : Node_Id;
Ignored : Traverse_Final_Result; Ignored : Traverse_Final_Result;
pragma Unreferenced (Ignored); pragma Unreferenced (Ignored);
...@@ -7213,44 +7215,49 @@ package body Sem_Ch6 is ...@@ -7213,44 +7215,49 @@ package body Sem_Ch6 is
begin begin
Prag := Spec_CTC_List (Contract (Spec)); Prag := Spec_CTC_List (Contract (Spec));
loop loop
-- Retrieve the Ensures component of the contract-case, if any if Pragma_Name (Prag) = Name_Contract_Cases then
Aggr := Expression (First
(Pragma_Argument_Associations (Prag)));
Arg := Get_Ensures_From_CTC_Pragma (Prag); Post_Case := First (Component_Associations (Aggr));
while Present (Post_Case) loop
Conseq := Expression (Post_Case);
-- Ignore trivial contract-case when Ensures component is "True" -- Ignore trivial contract-case when consequence is "True"
-- or "False". -- or "False".
if Pragma_Name (Prag) = Name_Contract_Case if not Is_Trivial_Post_Or_Ensures (Conseq) then
and then not Is_Trivial_Post_Or_Ensures (Expression (Arg))
then
-- Since contract-cases are listed in reverse order, the first
-- contract-case in the list is the last in the source.
if No (Last_Contract_Case) then Last_Contract_Cases := Prag;
Last_Contract_Case := Prag;
end if;
-- For functions, look for presence of 'Result in Ensures -- For functions, look for presence of 'Result in
-- consequence expression.
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
Ignored := Find_Attribute_Result (Arg); Ignored := Find_Attribute_Result (Conseq);
end if; end if;
-- For each individual contract-case, look for presence -- For each individual case, look for presence of an
-- of an expression that could be evaluated differently -- expression that could be evaluated differently in
-- in post-state. -- post-state.
Post_State_Mentioned := False; Post_State_Mentioned := False;
Ignored := Find_Post_State (Arg); Ignored := Find_Post_State (Conseq);
if Post_State_Mentioned then if Post_State_Mentioned then
No_Warning_On_Some_Postcondition := True; No_Warning_On_Some_Postcondition := True;
else else
Error_Msg_N Error_Msg_N
("`Ensures` component refers only to pre-state??", Prag); ("contract case refers only to pre-state?T?",
Conseq);
end if; end if;
end if; end if;
Next (Post_Case);
end loop;
end if;
Prag := Next_Pragma (Prag); Prag := Next_Pragma (Prag);
exit when No (Prag); exit when No (Prag);
end loop; end loop;
...@@ -7304,7 +7311,7 @@ package body Sem_Ch6 is ...@@ -7304,7 +7311,7 @@ package body Sem_Ch6 is
No_Warning_On_Some_Postcondition := True; No_Warning_On_Some_Postcondition := True;
else else
Error_Msg_N Error_Msg_N
("postcondition refers only to pre-state??", Prag); ("postcondition refers only to pre-state?T?", Prag);
end if; end if;
end if; end if;
end if; end if;
...@@ -7352,12 +7359,12 @@ package body Sem_Ch6 is ...@@ -7352,12 +7359,12 @@ package body Sem_Ch6 is
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
and then (Present (Last_Postcondition) and then (Present (Last_Postcondition)
or else Present (Last_Contract_Case)) or else Present (Last_Contract_Cases))
and then not Attribute_Result_Mentioned and then not Attribute_Result_Mentioned
and then No_Warning_On_Some_Postcondition and then No_Warning_On_Some_Postcondition
then then
if Present (Last_Postcondition) then if Present (Last_Postcondition) then
if Present (Last_Contract_Case) then if Present (Last_Contract_Cases) then
Error_Msg_N Error_Msg_N
("neither function postcondition nor " ("neither function postcondition nor "
& "contract cases mention result?T?", Last_Postcondition); & "contract cases mention result?T?", Last_Postcondition);
...@@ -7369,7 +7376,7 @@ package body Sem_Ch6 is ...@@ -7369,7 +7376,7 @@ package body Sem_Ch6 is
end if; end if;
else else
Error_Msg_N Error_Msg_N
("contract cases do not mention result?T?", Last_Contract_Case); ("contract cases do not mention result?T?", Last_Contract_Cases);
end if; end if;
end if; end if;
end Check_Subprogram_Contract; end Check_Subprogram_Contract;
......
gcc/ada/sem_elab.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1997-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3340,8 +3340,13 @@ package body Sem_Elab is ...@@ -3340,8 +3340,13 @@ package body Sem_Elab is
and then Pragma_Name (Item) = Name_Elaborate_All and then Pragma_Name (Item) = Name_Elaborate_All
then then
-- Return if some previous error on the pragma itself -- Return if some previous error on the pragma itself
-- The pragma may be unanalyzed, because of a previous error,
-- or if it is the context of a subunit, inherited by its
-- parent.
if Error_Posted (Item) then if Error_Posted (Item)
or else not Analyzed (Item)
then
return; return;
end if; end if;
......
gcc/ada/sem_prag.adb
...@@ -6871,8 +6871,8 @@ package body Sem_Prag is ...@@ -6871,8 +6871,8 @@ package body Sem_Prag is
-- declare additional states. -- declare additional states.
if Null_Seen then if Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id); Error_Msg_NE
Error_Msg_N ("package % has null abstract state", State); ("package & has null abstract state", State, Pack_Id);
-- Null states appear as internally generated entities -- Null states appear as internally generated entities
...@@ -6885,9 +6885,9 @@ package body Sem_Prag is ...@@ -6885,9 +6885,9 @@ package body Sem_Prag is
-- non-null states. -- non-null states.
if Non_Null_Seen then if Non_Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id); Error_Msg_NE
Error_Msg_N ("package & has non-null abstract state",
("package % has non-null abstract state", State); State, Pack_Id);
end if; end if;
-- Simple state declaration -- Simple state declaration
...@@ -11364,9 +11364,8 @@ package body Sem_Prag is ...@@ -11364,9 +11364,8 @@ package body Sem_Prag is
procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
begin begin
if Ekind (Subp_Id) = E_Function then if Ekind (Subp_Id) = E_Function then
Error_Msg_NE Error_Msg_N
("global mode & not applicable to functions", ("global mode & not applicable to functions", Mode);
Mode, Mode);
end if; end if;
end Check_Mode_Restriction_In_Function; end Check_Mode_Restriction_In_Function;
......
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