summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2010-10-22 10:09:51 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2010-10-22 10:09:51 +0000
commit6f104d01c71f83925f92499024dd6d3952d051ac (patch)
tree45498be02d1ed85f737aeb6644317efb5e0b4ca1 /gcc
parent9eb28c88ebbc286576aa88a06ecf963f6f12c069 (diff)
downloadgcc-6f104d01c71f83925f92499024dd6d3952d051ac.tar.gz
2010-10-22 Robert Dewar <dewar@adacore.com>
* sprint.adb: Minor reformatting. 2010-10-22 Robert Dewar <dewar@adacore.com> * exp_ch3.adb (Expand_N_Object_Declaration): Do required predicate checks. * sem_ch3.adb (Complete_Private_Subtype): Propagate predicates to full view. * sem_ch6.adb (Invariants_Or_Predicates_Present): New name for Invariants_Present. (Process_PPCs): Handle predicates generating post conditions * sem_util.adb (Is_Partially_Initialized_Type): Add Include_Null parameter. * sem_util.ads (Is_Partially_Initialized_Type): Add Include_Null parameter. 2010-10-22 Sergey Rybin <rybin@adacore.com> * gnat_ugn.texi (gnatelim): Add description for '--ignore' option 2010-10-22 Thomas Quinot <quinot@adacore.com> * sem_prag.adb (Check_First_Subtype): Specialize error messages for case where argument is not a type. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165815 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog27
-rw-r--r--gcc/ada/exp_ch3.adb18
-rw-r--r--gcc/ada/gnat_ugn.texi5
-rw-r--r--gcc/ada/sem_ch3.adb7
-rw-r--r--gcc/ada/sem_ch6.adb60
-rw-r--r--gcc/ada/sem_prag.adb30
-rw-r--r--gcc/ada/sem_util.adb17
-rw-r--r--gcc/ada/sem_util.ads8
-rw-r--r--gcc/ada/sprint.adb1
9 files changed, 135 insertions, 38 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a640b46f0a6..a726dd95b61 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,32 @@
2010-10-22 Robert Dewar <dewar@adacore.com>
+ * sprint.adb: Minor reformatting.
+
+2010-10-22 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Do required predicate
+ checks.
+ * sem_ch3.adb (Complete_Private_Subtype): Propagate predicates to full
+ view.
+ * sem_ch6.adb (Invariants_Or_Predicates_Present): New name for
+ Invariants_Present.
+ (Process_PPCs): Handle predicates generating post conditions
+ * sem_util.adb (Is_Partially_Initialized_Type): Add
+ Include_Null parameter.
+ * sem_util.ads (Is_Partially_Initialized_Type): Add
+ Include_Null parameter.
+
+2010-10-22 Sergey Rybin <rybin@adacore.com>
+
+ * gnat_ugn.texi (gnatelim): Add description for '--ignore' option
+
+2010-10-22 Thomas Quinot <quinot@adacore.com>
+
+ * sem_prag.adb (Check_First_Subtype): Specialize error messages for
+ case where argument is not a type.
+
+2010-10-22 Robert Dewar <dewar@adacore.com>
+
* exp_ch5.adb, par-ch4.adb, par-ch5.adb, sem_ch5.adb, sinfo.ads: Minor
reformatting.
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 0cb2b5bb517..b7d4c3b0036 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4508,6 +4508,24 @@ package body Exp_Ch3 is
return;
end if;
+ -- Deal with predicate check before we start to do major rewriting.
+ -- it is OK to initialize and then check the initialized value, since
+ -- the object goes out of scope if we get a predicate failure.
+
+ -- We need a predicate check if the type has predicates, and if either
+ -- there is an initializing expression, or for default initialization
+ -- when we have at least one case of an explicit default initial value.
+
+ if Present (Predicate_Function (Typ))
+ and then
+ (Present (Expr)
+ or else
+ Is_Partially_Initialized_Type (Typ, Include_Null => False))
+ then
+ Insert_After (N,
+ Make_Predicate_Check (Typ, New_Occurrence_Of (Def_Id, Loc)));
+ end if;
+
-- Force construction of dispatch tables of library level tagged types
if Tagged_Type_Expansion
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 9e4fe98376b..85459e4b408 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -10911,6 +10911,11 @@ Duplicate all the output sent to @file{stderr} into a specified log file.
@item ^--no-elim-dispatch^/NO_DISPATCH^
Do not generate pragmas for dispatching operations.
+@item ^--ignore^/IGNORE^=@var{filename}
+@cindex @option{^--ignore^/IGNORE^} (@command{gnatelim})
+Do not generate pragmas for subprograms declared in the sources
+listed in a specified file
+
@cindex @option{^-o^/OUTPUT^} (@command{gnatelim})
@item ^-o^/OUTPUT^=@var{report_file}
Put @command{gnatelim} output into a specified file. If this file already exists,
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 22d2fdf551e..dfbd7880e2e 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9913,6 +9913,13 @@ package body Sem_Ch3 is
Corresponding_Record_Type (Full_Base));
end if;
end if;
+
+ -- Copy rep item chain, and also setting of Has_Predicates from
+ -- private subtype to full subtype, since we will need these on the
+ -- full subtype to create the predicate function.
+
+ Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ Set_Has_Predicates (Full, Has_Predicates (Priv));
end Complete_Private_Subtype;
----------------------------
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 88918f3d179..98cb23793d5 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -207,8 +207,8 @@ package body Sem_Ch6 is
-- conditions for the body and assembling and inserting the _postconditions
-- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are
-- the entities for the body and separate spec (if there is no separate
- -- spec, Spec_Id is Empty). Note that invariants also provide a source
- -- of postconditions, which are also handled in this procedure.
+ -- spec, Spec_Id is Empty). Note that invariants and predicates may also
+ -- provide postconditions, and are also handled in this procedure.
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
@@ -8681,9 +8681,10 @@ package body Sem_Ch6 is
-- references to parameters of the inherited subprogram to point to the
-- corresponding parameters of the current subprogram.
- function Invariants_Present return Boolean;
- -- Determines if any invariants are present for any OUT or IN OUT
- -- parameters of the subprogram, or (for a function) for the return.
+ function Invariants_Or_Predicates_Present return Boolean;
+ -- Determines if any invariants or predicates are present for any OUT
+ -- or IN OUT parameters of the subprogram, or (for a function) if the
+ -- return value has an invariant.
--------------
-- Grab_PPC --
@@ -8782,12 +8783,12 @@ package body Sem_Ch6 is
return CP;
end Grab_PPC;
- ------------------------
- -- Invariants_Present --
- ------------------------
+ --------------------------------------
+ -- Invariants_Or_Predicates_Present --
+ --------------------------------------
- function Invariants_Present return Boolean is
- Formal : Entity_Id;
+ function Invariants_Or_Predicates_Present return Boolean is
+ Formal : Entity_Id;
begin
-- Check function return result
@@ -8803,7 +8804,9 @@ package body Sem_Ch6 is
Formal := First_Formal (Designator);
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter
- and then Has_Invariants (Etype (Formal))
+ and then
+ (Has_Invariants (Etype (Formal))
+ or else Present (Predicate_Function (Etype (Formal))))
then
return True;
end if;
@@ -8812,7 +8815,7 @@ package body Sem_Ch6 is
end loop;
return False;
- end Invariants_Present;
+ end Invariants_Or_Predicates_Present;
-- Start of processing for Process_PPCs
@@ -9084,7 +9087,7 @@ package body Sem_Ch6 is
-- If we had any postconditions and expansion is enabled, or if the
-- procedure has invariants, then build the _Postconditions procedure.
- if (Present (Plist) or else Invariants_Present)
+ if (Present (Plist) or else Invariants_Or_Predicates_Present)
and then Expander_Active
then
if No (Plist) then
@@ -9127,21 +9130,33 @@ package body Sem_Ch6 is
Parms := No_List;
end if;
- -- Add invariant calls for parameters. Note that this is done for
- -- functions as well, since in Ada 2012 they can have IN OUT args.
+ -- Add invariant calls and predicate calls for parameters. Note that
+ -- this is done for functions as well, since in Ada 2012 they can
+ -- have IN OUT args.
declare
Formal : Entity_Id;
+ Ftype : Entity_Id;
begin
Formal := First_Formal (Designator);
while Present (Formal) loop
- if Ekind (Formal) /= E_In_Parameter
- and then Has_Invariants (Etype (Formal))
- and then Present (Invariant_Procedure (Etype (Formal)))
- then
- Append_To (Plist,
- Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)));
+ if Ekind (Formal) /= E_In_Parameter then
+ Ftype := Etype (Formal);
+
+ if Has_Invariants (Ftype)
+ and then Present (Invariant_Procedure (Ftype))
+ then
+ Append_To (Plist,
+ Make_Invariant_Call
+ (New_Occurrence_Of (Formal, Loc)));
+ end if;
+
+ if Present (Predicate_Function (Ftype)) then
+ Append_To (Plist,
+ Make_Predicate_Check
+ (Ftype, New_Occurrence_Of (Formal, Loc)));
+ end if;
end if;
Next_Formal (Formal);
@@ -9365,6 +9380,7 @@ package body Sem_Ch6 is
if Ekind (Scope (Formal_Id)) = E_Function
or else Ekind (Scope (Formal_Id)) = E_Generic_Function
then
+ -- [IN] OUT parameters allowed for functions in Ada 2012
if Ada_Version >= Ada_2012 then
if In_Present (Spec) then
@@ -9373,6 +9389,8 @@ package body Sem_Ch6 is
Set_Ekind (Formal_Id, E_Out_Parameter);
end if;
+ -- But not in earlier versions of Ada
+
else
Error_Msg_N ("functions can only have IN parameters", Spec);
Set_Ekind (Formal_Id, E_In_Parameter);
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 552f4b1a30b..6bd33a9599d 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -410,8 +410,8 @@ package body Sem_Prag is
-- case, and if found, issues an appropriate error message.
procedure Check_First_Subtype (Arg : Node_Id);
- -- Checks that Arg, whose expression is an entity name referencing a
- -- subtype, does not reference a type that is not a first subtype.
+ -- Checks that Arg, whose expression is an entity name, references a
+ -- first subtype.
procedure Check_In_Main_Program;
-- Common checks for pragmas that appear within a main program
@@ -976,8 +976,7 @@ package body Sem_Prag is
Check_Arg_Is_Identifier (Argx);
if not Is_Locking_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid locking policy name", Argx);
+ Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
end if;
end Check_Arg_Is_Locking_Policy;
@@ -1032,7 +1031,6 @@ package body Sem_Prag is
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
-
---------------------------------
-- Check_Arg_Is_Queuing_Policy --
---------------------------------
@@ -1044,8 +1042,7 @@ package body Sem_Prag is
Check_Arg_Is_Identifier (Argx);
if not Is_Queuing_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid queuing policy name", Argx);
+ Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
end if;
end Check_Arg_Is_Queuing_Policy;
@@ -1210,9 +1207,7 @@ package body Sem_Prag is
S : Entity_Id := Id;
begin
- while Present (S)
- and then S /= Standard_Standard
- loop
+ while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
@@ -1342,10 +1337,22 @@ package body Sem_Prag is
procedure Check_First_Subtype (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Ent : constant Entity_Id := Entity (Argx);
begin
- if not Is_First_Subtype (Entity (Argx)) then
+ if Is_First_Subtype (Ent) then
+ null;
+
+ elsif Is_Type (Ent) then
Error_Pragma_Arg
("pragma% cannot apply to subtype", Argx);
+
+ elsif Is_Object (Ent) then
+ Error_Pragma_Arg
+ ("pragma% cannot apply to object, requires a type", Argx);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% cannot apply to&, requires a type", Argx);
end if;
end Check_First_Subtype;
@@ -2188,6 +2195,7 @@ package body Sem_Prag is
if Error_Msg_Name_1 = Name_Precondition then
Error_Msg_Name_1 := Name_Pre;
+
elsif Error_Msg_Name_1 = Name_Postcondition then
Error_Msg_Name_1 := Name_Post;
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 109ee580976..fb259067cbe 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6776,19 +6776,24 @@ package body Sem_Util is
-- Is_Partially_Initialized_Type --
-----------------------------------
- function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
+ function Is_Partially_Initialized_Type
+ (Typ : Entity_Id;
+ Include_Null : Boolean := True) return Boolean
+ is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
- return True;
+ return Include_Null;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
- if Is_Partially_Initialized_Type (Component_Type (Typ)) then
+ if Is_Partially_Initialized_Type
+ (Component_Type (Typ), Include_Null)
+ then
return True;
-- Otherwise we are only partially initialized if we are fully
@@ -6841,7 +6846,9 @@ package body Sem_Util is
-- If a component is of a type which is itself partially
-- initialized, then the enclosing record type is also.
- elsif Is_Partially_Initialized_Type (Etype (Ent)) then
+ elsif Is_Partially_Initialized_Type
+ (Etype (Ent), Include_Null)
+ then
return True;
end if;
end if;
@@ -6880,7 +6887,7 @@ package body Sem_Util is
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U);
+ return Is_Partially_Initialized_Type (U, Include_Null);
end if;
end;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index be4987b9494..975d724f732 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -760,12 +760,18 @@ package Sem_Util is
-- the Is_Variable sense) with a non-tagged type target are considered view
-- conversions and hence variables.
- function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean;
+ function Is_Partially_Initialized_Type
+ (Typ : Entity_Id;
+ Include_Null : Boolean := True) return Boolean;
-- Typ is a type entity. This function returns true if this type is partly
-- initialized, meaning that an object of the type is at least partly
-- initialized (in particular in the record case, that at least one
-- component has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
+ -- Include_Null controls the handling of access types, and components of
+ -- access types not explicitly initialized. If set to True, the default,
+ -- default initialization of access types counts as making the type be
+ -- partially initialized. If False, this does not count.
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
-- Determines if type T is a potentially persistent type. A potentially
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 627fb2f28bd..e984b5bc85d 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -1995,6 +1995,7 @@ package body Sprint is
Sprint_Node (Condition (Node));
else
Write_Str_With_Col_Check_Sloc ("for ");
+
if Present (Iterator_Specification (Node)) then
Sprint_Node (Iterator_Specification (Node));
else