+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.
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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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;
-- 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.
-- 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);
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
-- 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 ");
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;
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
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
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;
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;
-- 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;
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
end loop;
Write_Eol;
- List_Entities (Cunit_Entity (U));
+ List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
-- List representation information to file
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;
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 --
--------------------
-- --
-- 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- --
-- 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
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
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))
-- 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
----------------------------
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);
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);
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;
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);
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;
-- --
-- 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- --
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;
-- 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
-- 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
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;
OSDN Git Service
