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.
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
@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,
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;
----------------------------
-- 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
-- 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 --
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
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;
end loop;
return False;
- end Invariants_Present;
+ end Invariants_Or_Predicates_Present;
-- Start of processing for Process_PPCs
-- 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
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);
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
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);
-- 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
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;
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
-
---------------------------------
-- Check_Arg_Is_Queuing_Policy --
---------------------------------
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;
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
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;
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;
-- 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
-- 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;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U);
+ return Is_Partially_Initialized_Type (U, Include_Null);
end if;
end;
-- 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
Sprint_Node (Condition (Node));
else
Write_Str_With_Col_Check_Sloc ("for ");
+
if Present (Iterator_Specification (Node)) then
Sprint_Node (Iterator_Specification (Node));
else
projects / platform / upstream / linaro-gcc.git / commitdiff