+2015-01-07 Robert Dewar <dewar@adacore.com>
+
+ * sem_warn.adb (Check_One_Unit): Don't give unused entities
+ warning for a package which is used as a generic parameter.
+
+2015-01-07 Bob Duff <duff@adacore.com>
+
+ * usage.adb (Usage): Correct documentation of
+ -gnatw.f switches.
+
+2015-01-07 Robert Dewar <dewar@adacore.com>
+
+ * s-fileio.adb: Minor reformatting.
+
+2015-01-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Object): If formal is an anonymous
+ access to subprogram, replace its formals with new entities when
+ building the object declaration, both if actual is present and
+ when it is defaulted.
+
+2015-01-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): If left-hand side is a view
+ conversion and type of expression has invariant, apply invariant
+ check on expression.
+
+2015-01-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Create_Constrained_Components): A call to
+ Gather_Components may detect an error if an inherited discriminant
+ that controls a variant is non-static.
+ * sem_aggr.adb (Resolve_Record_Aggregate, Step 5): The call to
+ Gather_Components may report an error if an inherited discriminant
+ in a variant in non-static.
+ * sem_util.adb (Gather_Components): If a non-static discriminant
+ is inherited do not report error here, but let caller handle it.
+ (Find_Actual): Small optimization.
+
2015-01-07 Bob Duff <duff@adacore.com>
* usage.adb (Usage): Document -gnatw.f switch.
-----------
procedure Close (File_Ptr : access AFCB_Ptr) is
- Close_Status : int := 0;
+ Close_Status : int := 0;
Dup_Strm : Boolean := False;
- File : AFCB_Ptr renames File_Ptr.all;
Errno : Integer := 0;
+ File : AFCB_Ptr renames File_Ptr.all;
+
begin
-- Take a task lock, to protect the global data value Open_Files
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
+
+ if Errors_Found then
+ Error_Msg_N
+ ("discriminant controlling variant part is not static",
+ N);
+ return;
+ end if;
end if;
end if;
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
- Set_Comes_From_Source (Act_Decl_Id, True);
+
+ -- Subprogram instance comes from source only if generic does
+
+ Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit));
-- The signature may involve types that are not frozen yet, but the
-- subprogram will be frozen at the point the wrapper package is
Subt_Decl : Node_Id := Empty;
Subt_Mark : Node_Id := Empty;
+ function Copy_Access_Def return Node_Id;
+ -- If formal is an anonymous access, copy access definition of formal
+ -- for generated object declaration.
+
+ ---------------------
+ -- Copy_Access_Def --
+ ---------------------
+
+ function Copy_Access_Def return Node_Id is
+ begin
+ Def := New_Copy_Tree (Acc_Def);
+
+ -- In addition, if formal is an access to subprogram we need to
+ -- generate new formals for the signature of the default, so that
+ -- the tree is properly formatted for ASIS use.
+
+ if Present (Access_To_Subprogram_Definition (Acc_Def)) then
+ declare
+ Par_Spec : Node_Id;
+ begin
+ Par_Spec :=
+ First (Parameter_Specifications
+ (Access_To_Subprogram_Definition (Def)));
+ while Present (Par_Spec) loop
+ Set_Defining_Identifier (Par_Spec,
+ Make_Defining_Identifier (Sloc (Acc_Def),
+ Chars => Chars (Defining_Identifier (Par_Spec))));
+ Next (Par_Spec);
+ end loop;
+ end;
+ end if;
+
+ return Def;
+ end Copy_Access_Def;
+
+ -- Start of processing for Instantiate_Object
+
begin
-- Formal may be an anonymous access
if Present (Subt_Mark) then
Def := New_Copy_Tree (Subt_Mark);
else pragma Assert (Present (Acc_Def));
- Def := Copy_Separate_Tree (Acc_Def);
+ Def := Copy_Access_Def;
end if;
Decl_Node :=
if Present (Subt_Mark) then
Def := New_Copy (Subt_Mark);
-
else pragma Assert (Present (Acc_Def));
-
- -- If formal is an anonymous access, copy access definition of
- -- formal for object declaration.
- -- In the case of an access to subprogram we need to
- -- generate new formals for the signature of the default.
-
- Def := Copy_Separate_Tree (Acc_Def);
+ Def := Copy_Access_Def;
end if;
Decl_Node :=
then
Collect_Fixed_Components (Typ);
- Gather_Components (
- Typ,
- Component_List (Type_Definition (Parent (Parent_Type))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
- pragma Assert (not Errors);
+ Gather_Components
+ (Typ,
+ Component_List (Type_Definition (Parent (Parent_Type))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+
+ -- Note: previously there was a check at this point that no errors
+ -- were detected. As a consequence of AI05-220 there may be an error
+ -- if an inherited discriminant that controls a variant has a non-
+ -- static constraint.
-- If the tagged derivation has a type extension, collect all the
-- new components therein.
- if Present
- (Record_Extension_Part (Type_Definition (Parent (Typ))))
+ if Present (Record_Extension_Part (Type_Definition (Parent (Typ))))
then
Old_C := First_Component (Typ);
while Present (Old_C) loop
Set_Referenced_Modified (Lhs, Out_Param => False);
end if;
+ -- RM 7.3.2 (12/3) An assignment to a view conversion (from a type
+ -- to one of its ancestors) requires an invariant check. Apply check
+ -- only if expression comes from source, otherwise it will be applied
+ -- when value is assigned to source entity.
+
+ if Nkind (Lhs) = N_Type_Conversion
+ and then Has_Invariants (Etype (Expression (Lhs)))
+ and then Comes_From_Source (Expression (Lhs))
+ then
+ Insert_After (N, Make_Invariant_Call (Expression (Lhs)));
+ end if;
+
-- Final step. If left side is an entity, then we may be able to reset
-- the current tracked values to new safe values. We only have something
-- to do if the left side is an entity name, and expansion has not
and then Is_Overloadable (Entity (Name (Call)))
and then not Is_Overloaded (Name (Call))
then
+ -- If node is name in call it is not an actual
+
+ if N = Name (Call) then
+ Call := Empty;
+ Formal := Empty;
+ return;
+ end if;
+
-- Fall here if we are definitely a parameter
Actual := First_Actual (Call);
Discrim_Value := Expression (Assoc);
if not Is_OK_Static_Expression (Discrim_Value) then
- Error_Msg_FE
- ("value for discriminant & must be static!",
- Discrim_Value, Discrim);
- Why_Not_Static (Discrim_Value);
+
+ -- If the variant part is governed by a discriminant of the type
+ -- this is an error. If the variant part and the discriminant are
+ -- inherited from an ancestor this is legal (AI05-120) unless the
+ -- components are being gathered for an aggregate, in which case
+ -- the caller must check Report_Errors.
+
+ if Scope (Original_Record_Component
+ ((Entity (First (Choices (Assoc)))))) = Typ
+ then
+ Error_Msg_FE
+ ("value for discriminant & must be static!",
+ Discrim_Value, Discrim);
+ Why_Not_Static (Discrim_Value);
+ end if;
+
Report_Errors := True;
return;
end if;
elsif Check_System_Aux then
null;
- -- Else give the warning
+ -- Else the warning may be needed
else
- -- Warn if we unreferenced flag set and we have
- -- not had serious errors. The reason we inhibit
- -- the message if there are errors is to prevent
- -- false positives from disabling expansion.
-
- if not Has_Unreferenced (Entity (Name (Item)))
- and then Serious_Errors_Detected = 0
- then
- Error_Msg_N -- CODEFIX
- ("?u?no entities of & are referenced!",
- Name (Item));
- end if;
-
- -- Look for renamings of this package, and flag
- -- them as well. If the original package has
- -- warnings off, we suppress the warning on the
- -- renaming as well.
-
- Pack := Find_Package_Renaming (Munite, Lunit);
-
- if Present (Pack)
- and then not Has_Warnings_Off (Lunit)
- and then not Has_Unreferenced (Pack)
- then
- Error_Msg_NE -- CODEFIX
- ("?u?no entities of & are referenced!",
- Unit_Declaration_Node (Pack),
- Pack);
- end if;
+ declare
+ Eitem : constant Entity_Id :=
+ Entity (Name (Item));
+
+ begin
+ -- Warn if we unreferenced flag set and we
+ -- have not had serious errors. The reason we
+ -- inhibit the message if there are errors is
+ -- to prevent false positives from disabling
+ -- expansion.
+
+ if not Has_Unreferenced (Eitem)
+ and then Serious_Errors_Detected = 0
+ then
+ -- Get possible package renaming
+
+ Pack :=
+ Find_Package_Renaming (Munite, Lunit);
+
+ -- No warning if either the package or its
+ -- renaming is used as a generic actual.
+
+ if Used_As_Generic_Actual (Eitem)
+ or else
+ (Present (Pack)
+ and then
+ Used_As_Generic_Actual (Pack))
+ then
+ exit;
+ end if;
+
+ -- Here we give the warning
+
+ Error_Msg_N -- CODEFIX
+ ("?u?no entities of & are referenced!",
+ Name (Item));
+
+ -- Flag renaming of package as well. If
+ -- the original package has warnings off,
+ -- we suppress the warning on the renaming
+ -- as well.
+
+ if Present (Pack)
+ and then not Has_Warnings_Off (Lunit)
+ and then not Has_Unreferenced (Pack)
+ then
+ Error_Msg_NE -- CODEFIX
+ ("?u?no entities of& are referenced!",
+ Unit_Declaration_Node (Pack), Pack);
+ end if;
+ end if;
+ end;
end if;
exit;
Write_Line (" f+ turn on warnings for unreferenced formal");
Write_Line (" F* turn off warnings for unreferenced formal");
Write_Line (" .f turn on warnings for suspicious Subp'Access");
- Write_Line (" .F turn off warnings for suspicious Subp'Access");
+ Write_Line (" .F* turn off warnings for suspicious Subp'Access");
Write_Line (" g*+ turn on warnings for unrecognized pragma");
Write_Line (" G turn off warnings for unrecognized pragma");
Write_Line (" .g turn on GNAT warnings");
projects / gcc.git / commitdiff