[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
This commit is contained in:
Arnaud Charlet 2013-04-12 15:08:07 +02:00
parent 2eb8701742
commit d9f8616ee4
8 changed files with 178 additions and 86 deletions

@ -1,3 +1,30 @@
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>
* a-cfdlli.ads, g-socket.adb, s-fileio.adb: Minor reformatting.

@ -1259,7 +1259,7 @@ begin
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
List_Rep_Info;
List_Rep_Info (Ttypes.Bytes_Big_Endian);
List_Inlining_Info;
-- Only write the library if the backend did not generate any error

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -29,22 +29,23 @@
-- --
------------------------------------------------------------------------------
with Alloc; use Alloc;
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Table; use Table;
with Uname; use Uname;
with Urealp; use Urealp;
with Alloc; use Alloc;
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Table; use Table;
with Uname; use Uname;
with Urealp; use Urealp;
with Ada.Unchecked_Conversion;
@ -133,7 +134,7 @@ package body Repinfo is
-- Called before outputting anything for an entity. Ensures that
-- 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
-- with the First_Entity and using the Next_Entity link. If a nested
-- package is found, entities within the package are recursively processed.
@ -142,7 +143,7 @@ package body Repinfo is
-- List name of entity Ent in appropriate case. The name is listed with
-- 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
procedure List_Mechanisms (Ent : Entity_Id);
@ -152,9 +153,14 @@ package body Repinfo is
procedure List_Object_Info (Ent : Entity_Id);
-- 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
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);
-- List type info for type Ent
@ -286,7 +292,7 @@ package body Repinfo is
-- List_Array_Info --
----------------------
procedure List_Array_Info (Ent : Entity_Id) is
procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
begin
List_Type_Info (Ent);
Write_Str ("for ");
@ -294,13 +300,15 @@ package body Repinfo is
Write_Str ("'Component_Size use ");
Write_Val (Component_Size (Ent));
Write_Line (";");
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
end List_Array_Info;
-------------------
-- List_Entities --
-------------------
procedure List_Entities (Ent : Entity_Id) is
procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
Body_E : Entity_Id;
E : Entity_Id;
@ -379,12 +387,12 @@ package body Repinfo is
elsif Is_Record_Type (E) then
if List_Representation_Info >= 1 then
List_Record_Info (E);
List_Record_Info (E, Bytes_Big_Endian);
end if;
elsif Is_Array_Type (E) then
if List_Representation_Info >= 1 then
List_Array_Info (E);
List_Array_Info (E, Bytes_Big_Endian);
end if;
elsif Is_Type (E) then
@ -411,7 +419,7 @@ package body Repinfo is
if Ekind (E) = E_Package then
if No (Renamed_Object (E)) then
List_Entities (E);
List_Entities (E, Bytes_Big_Endian);
end if;
-- Recurse into bodies
@ -428,12 +436,12 @@ package body Repinfo is
or else
Ekind (E) = E_Protected_Body
then
List_Entities (E);
List_Entities (E, Bytes_Big_Endian);
-- Recurse into blocks
elsif Ekind (E) = E_Block then
List_Entities (E);
List_Entities (E, Bytes_Big_Endian);
end if;
end if;
@ -461,7 +469,7 @@ package body Repinfo is
and then
Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
then
List_Entities (Body_E);
List_Entities (Body_E, Bytes_Big_Endian);
end if;
end if;
@ -779,7 +787,7 @@ package body Repinfo is
-- 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;
Cfbit : Uint;
Sunit : Uint;
@ -963,13 +971,15 @@ package body Repinfo is
end loop;
Write_Line ("end record;");
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
end List_Record_Info;
-------------------
-- List_Rep_Info --
-------------------
procedure List_Rep_Info is
procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
Col : Nat;
begin
@ -994,7 +1004,7 @@ package body Repinfo is
end loop;
Write_Eol;
List_Entities (Cunit_Entity (U));
List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
-- List representation information to file
@ -1002,7 +1012,7 @@ package body Repinfo is
Create_Repinfo_File_Access.all
(Get_Name_String (File_Name (Source_Index (U))));
Set_Special_Output (Write_Info_Line'Access);
List_Entities (Cunit_Entity (U));
List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
Set_Special_Output (null);
Close_Repinfo_File_Access.all;
end if;
@ -1011,6 +1021,49 @@ package body Repinfo is
end if;
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 --
--------------------

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -283,8 +283,9 @@ package Repinfo is
-- Compiler Interface --
------------------------
procedure List_Rep_Info;
-- Procedure to list representation information
procedure List_Rep_Info (Bytes_Big_Endian : Boolean);
-- Procedure to list representation information. Bytes_Big_Endian is the
-- value from Ttypes (Repinfo cannot have a dependency on Ttypes).
procedure Tree_Write;
-- Writes out internal tables to current tree file using the relevant

@ -4314,8 +4314,8 @@ package body Sem_Attr is
Arg := Parent (Arg);
end loop;
-- At this point, Parent (Arg) should be a
-- N_Component_Association. Attribute Old is only allowed in
-- At this point, Parent (Arg) should be a component
-- association. Attribute Result is only allowed in
-- the expression part of this association.
if Nkind (Parent (Arg)) /= N_Component_Association
@ -4731,9 +4731,9 @@ package body Sem_Attr is
Arg := Parent (Arg);
end loop;
-- At this point, Parent (Arg) should be a
-- N_Component_Association. Attribute Result is only
-- allowed in the expression part of this association.
-- At this point, Parent (Arg) should be a component
-- association. Attribute Result is only allowed in
-- the expression part of this association.
if Nkind (Parent (Arg)) /= N_Component_Association
or else Arg /= Expression (Parent (Arg))

@ -7064,8 +7064,8 @@ package body Sem_Ch6 is
-- Last non-trivial postcondition on the subprogram, or else Empty if
-- either no non-trivial postcondition or only inherited postconditions.
Last_Contract_Case : Node_Id := Empty;
-- Last non-trivial contract-case on the subprogram, or else Empty
Last_Contract_Cases : Node_Id := Empty;
-- Last non-trivial contract-cases on the subprogram, or else Empty
Attribute_Result_Mentioned : Boolean := False;
-- Whether attribute 'Result is mentioned in a non-trivial postcondition
@ -7204,8 +7204,10 @@ package body Sem_Ch6 is
----------------------------
procedure Process_Contract_Cases (Spec : Node_Id) is
Prag : Node_Id;
Arg : Node_Id;
Prag : Node_Id;
Aggr : Node_Id;
Conseq : Node_Id;
Post_Case : Node_Id;
Ignored : Traverse_Final_Result;
pragma Unreferenced (Ignored);
@ -7213,42 +7215,47 @@ package body Sem_Ch6 is
begin
Prag := Spec_CTC_List (Contract (Spec));
loop
-- Retrieve the Ensures component of the contract-case, if any
if Pragma_Name (Prag) = Name_Contract_Cases then
Arg := Get_Ensures_From_CTC_Pragma (Prag);
Aggr := Expression (First
(Pragma_Argument_Associations (Prag)));
-- Ignore trivial contract-case when Ensures component is "True"
-- or "False".
Post_Case := First (Component_Associations (Aggr));
while Present (Post_Case) loop
Conseq := Expression (Post_Case);
if Pragma_Name (Prag) = Name_Contract_Case
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.
-- Ignore trivial contract-case when consequence is "True"
-- or "False".
if No (Last_Contract_Case) then
Last_Contract_Case := Prag;
end if;
if not Is_Trivial_Post_Or_Ensures (Conseq) then
-- For functions, look for presence of 'Result in Ensures
Last_Contract_Cases := Prag;
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
Ignored := Find_Attribute_Result (Arg);
end if;
-- For functions, look for presence of 'Result in
-- consequence expression.
-- For each individual contract-case, look for presence
-- of an expression that could be evaluated differently
-- in post-state.
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
Ignored := Find_Attribute_Result (Conseq);
end if;
Post_State_Mentioned := False;
Ignored := Find_Post_State (Arg);
-- For each individual case, look for presence of an
-- expression that could be evaluated differently in
-- post-state.
if Post_State_Mentioned then
No_Warning_On_Some_Postcondition := True;
else
Error_Msg_N
("`Ensures` component refers only to pre-state??", Prag);
end if;
Post_State_Mentioned := False;
Ignored := Find_Post_State (Conseq);
if Post_State_Mentioned then
No_Warning_On_Some_Postcondition := True;
else
Error_Msg_N
("contract case refers only to pre-state?T?",
Conseq);
end if;
end if;
Next (Post_Case);
end loop;
end if;
Prag := Next_Pragma (Prag);
@ -7304,7 +7311,7 @@ package body Sem_Ch6 is
No_Warning_On_Some_Postcondition := True;
else
Error_Msg_N
("postcondition refers only to pre-state??", Prag);
("postcondition refers only to pre-state?T?", Prag);
end if;
end if;
end if;
@ -7352,12 +7359,12 @@ package body Sem_Ch6 is
if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
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 No_Warning_On_Some_Postcondition
then
if Present (Last_Postcondition) then
if Present (Last_Contract_Case) then
if Present (Last_Contract_Cases) then
Error_Msg_N
("neither function postcondition nor "
& "contract cases mention result?T?", Last_Postcondition);
@ -7369,7 +7376,7 @@ package body Sem_Ch6 is
end if;
else
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 Check_Subprogram_Contract;

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -3340,8 +3340,13 @@ package body Sem_Elab is
and then Pragma_Name (Item) = Name_Elaborate_All
then
-- 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;
end if;

@ -6871,8 +6871,8 @@ package body Sem_Prag is
-- declare additional states.
if Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N ("package % has null abstract state", State);
Error_Msg_NE
("package & has null abstract state", State, Pack_Id);
-- Null states appear as internally generated entities
@ -6885,9 +6885,9 @@ package body Sem_Prag is
-- non-null states.
if Non_Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N
("package % has non-null abstract state", State);
Error_Msg_NE
("package & has non-null abstract state",
State, Pack_Id);
end if;
-- Simple state declaration
@ -11364,9 +11364,8 @@ package body Sem_Prag is
procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
begin
if Ekind (Subp_Id) = E_Function then
Error_Msg_NE
("global mode & not applicable to functions",
Mode, Mode);
Error_Msg_N
("global mode & not applicable to functions", Mode);
end if;
end Check_Mode_Restriction_In_Function;