+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * style.adb: Fix typo.
+
+2017-09-08 Javier Miranda <miranda@adacore.com>
+
+ * einfo.adb (Underlying_Type): Add missing support for class-wide
+ types that come from the limited view.
+ * exp_attr.adb (Attribute_Address): Check class-wide type
+ interfaces using the underlying type to handle limited-withed
+ types.
+ (Attribute_Tag): Check class-wide type interfaces using
+ the underlying type to handle limited-withed types.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_Predicated_Loop): Handle properly a loop
+ over a subtype of a type with a static predicate, taking into
+ account the predicate function of the parent type and the bounds
+ given in the loop specification.
+ * sem_ch3.adb (Inherit_Predicate_Flags): For qn Itype created for
+ a loop specification that is a subtype indication whose type mark
+ is a type with a static predicate, inherit predicate function,
+ used to build case statement for rewritten loop.
+
+2017-09-08 Justin Squirek <squirek@adacore.com>
+
+ * lib-load.adb: Modify printing of error message to exclude file
+ line number.
+
+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * inline.adb (Can_Be_Inlined_In_GNATprove_Mode):
+ don't inline subprograms declared in both visible and private
+ parts of a package.
+ (In_Package_Spec): previously In_Package_Visible_Spec; now
+ detects subprograms declared both in visible and private parts
+ of a package spec.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Build_Invariant_Procedure_Declaration): If
+ the type is an anonymous array in an object declaration, whose
+ component type has an invariant, use the object declaration
+ as the insertion point for the invariant procedure, given that
+ there is no explicit type declaration for an anonymous array type.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * a-cbprqu.ads, a-cbdlli.adb: Suppress warnings.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * a-strfix.adb (Trim): Compute Low and High only if needed.
+
+2017-09-08 Justin Squirek <squirek@adacore.com>
+
+ * lib-load.adb (Load_Main_Source): Add error output in the case a
+ source file is missing.
+
2017-09-08 Bob Duff <duff@adacore.com>
PR ada/80888
Position : out Cursor;
Count : Count_Type := 1)
is
+ pragma Warnings (Off);
New_Item : Element_Type;
- pragma Unmodified (New_Item);
- -- OK to reference, see below. Needed to suppress front end warning.
+ -- OK to reference, see below. Note that we need to suppress both the
+ -- front end warning and the back end warning.
begin
-- There is no explicit element provided, but in an instance the element
-- initialization, so insert the specified number of possibly
-- initialized elements at the given position.
- pragma Warnings (Off); -- Needed to suppress back end warning
Insert (Container, Before, New_Item, Position, Count);
pragma Warnings (On);
end Insert;
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- We need a better data structure here, such as a proper heap. ???
+ pragma Warnings (Off);
+ -- Otherwise, we get warnings for the uninitialized variable in Insert
+ -- in Ada.Containers.Bounded_Doubly_Linked_Lists.
package List_Types is new Bounded_Doubly_Linked_Lists
(Element_Type => Queue_Interfaces.Element_Type,
"=" => Queue_Interfaces."=");
+ pragma Warnings (On);
type List_Type (Capacity : Count_Type) is tagged limited record
Container : List_Types.List (Capacity);
if Ekind (Id) = E_Record_Type_With_Private then
return Full_View (Id);
+ -- If we have a class-wide type that comes from the limited view then
+ -- we return the Underlying_Type of its nonlimited view.
+
+ elsif Ekind (Id) = E_Class_Wide_Type
+ and then From_Limited_With (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Underlying_Type (Non_Limited_View (Id));
+
elsif Ekind (Id) in Incomplete_Or_Private_Kind then
-- If we have an incomplete or private type with a full view,
then
return Underlying_Type (Underlying_Full_View (Id));
- -- If we have an incomplete entity that comes from the limited
- -- view then we return the Underlying_Type of its non-limited
- -- view.
+ -- If we have an incomplete entity that comes from the limited view
+ -- then we return the Underlying_Type of its nonlimited view.
elsif From_Limited_With (Id)
and then Present (Non_Limited_View (Id))
-- issues are taken care of by the virtual machine.
elsif Is_Class_Wide_Type (Ptyp)
- and then Is_Interface (Ptyp)
+ and then Is_Interface (Underlying_Type (Ptyp))
and then Tagged_Type_Expansion
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
elsif Comes_From_Source (N)
and then Is_Class_Wide_Type (Etype (Prefix (N)))
- and then Is_Interface (Etype (Prefix (N)))
+ and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
then
-- Generate:
-- (To_Tag_Ptr (Prefix'Address)).all
-- end loop;
-- end;
+ -- In addition, if the loop specification is given by a subtype
+ -- indication that constrains a predicated type, the bounds of
+ -- iteration are given by those of the subtype indication.
+
else
Static_Predicate : declare
S : Node_Id;
Alts : List_Id;
Cstm : Node_Id;
+ -- If the domain is an itype, note the bounds of its range.
+
+ L_Hi : Node_Id;
+ L_Lo : Node_Id;
+
function Lo_Val (N : Node_Id) return Node_Id;
-- Given static expression or static range, returns an identifier
-- whose value is the low bound of the expression value or range.
Set_Warnings_Off (Loop_Id);
+ if Is_Itype (Ltype) then
+ L_Hi := High_Bound (Scalar_Range (Ltype));
+ L_Lo := Low_Bound (Scalar_Range (Ltype));
+ end if;
+
-- Loop to create branches of case statement
Alts := New_List;
-- Initial value is largest value in predicate.
- D :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Loop_Id,
- Object_Definition => New_Occurrence_Of (Ltype, Loc),
- Expression => Hi_Val (Last (Stat)));
+ if Is_Itype (Ltype) then
+ D :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Object_Definition => New_Occurrence_Of (Ltype, Loc),
+ Expression => L_Hi);
+
+ else
+ D :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Object_Definition => New_Occurrence_Of (Ltype, Loc),
+ Expression => Hi_Val (Last (Stat)));
+ end if;
P := Last (Stat);
while Present (P) loop
Prev (P);
end loop;
+ if Is_Itype (Ltype)
+ and then Is_OK_Static_Expression (L_Lo)
+ and then
+ Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat)))
+ then
+ Append_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Statements => New_List (Make_Exit_Statement (Loc)),
+ Discrete_Choices => New_List (L_Lo)));
+ end if;
+
else
-- Initial value is smallest value in predicate.
- D :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Loop_Id,
- Object_Definition => New_Occurrence_Of (Ltype, Loc),
- Expression => Lo_Val (First (Stat)));
+ if Is_Itype (Ltype) then
+ D :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Object_Definition => New_Occurrence_Of (Ltype, Loc),
+ Expression => L_Lo);
+ else
+ D :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Object_Definition => New_Occurrence_Of (Ltype, Loc),
+ Expression => Lo_Val (First (Stat)));
+ end if;
P := First (Stat);
while Present (P) loop
Next (P);
end loop;
+
+ if Is_Itype (Ltype)
+ and then Is_OK_Static_Expression (L_Hi)
+ and then
+ Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat)))
+ then
+ Append_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Statements => New_List (Make_Exit_Statement (Loc)),
+ Discrete_Choices => New_List (L_Hi)));
+ end if;
end if;
-- Add others choice
-- Derived types with the full view as parent do not have a partial
-- view. Insert the invariant procedure after the derived type.
+ -- Anonymous arrays in object declarations have no explicit declaration
+ -- so use the related object declaration as the insertion point.
+
+ elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
+ Typ_Decl := Associated_Node_For_Itype (Work_Typ);
else
Typ_Decl := Declaration_Node (Full_Typ);
-- Returns True if subprogram Id defines a compilation unit
-- Shouldn't this be in Sem_Aux???
- function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
- -- Returns True if subprogram Id is defined in the visible part of a
- -- package specification.
+ function In_Package_Spec (Id : Node_Id) return Boolean;
+ -- Returns True if subprogram Id is defined in the package
+ -- specification, either its visible or private part.
---------------------------------------------------
-- Has_Formal_With_Discriminant_Dependent_Fields --
return False;
end Has_Some_Contract;
- -----------------------------
- -- In_Package_Visible_Spec --
- -----------------------------
+ ---------------------
+ -- In_Package_Spec --
+ ---------------------
- function In_Package_Visible_Spec (Id : Node_Id) return Boolean is
- Decl : Node_Id := Parent (Parent (Id));
- P : Node_Id;
+ function In_Package_Spec (Id : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (Subprogram_Spec (Id));
+ -- Parent of the subprogram's declaration
begin
- if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
- Decl := Parent (Decl);
- end if;
-
- P := Parent (Decl);
-
- return Nkind (P) = N_Package_Specification
- and then List_Containing (Decl) = Visible_Declarations (P);
- end In_Package_Visible_Spec;
+ return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
+ end In_Package_Spec;
------------------------
-- Is_Unit_Subprogram --
if Is_Unit_Subprogram (Id) then
return False;
- -- Do not inline subprograms declared in the visible part of a package
+ -- Do not inline subprograms declared in package specs, because they are
+ -- not local, i.e. can be called either from anywhere (if declared in
+ -- visible part) or from the child units (if declared in private part).
- elsif In_Package_Visible_Spec (Id) then
+ elsif In_Package_Spec (Id) then
return False;
-- Do not inline subprograms declared in other units. This is important
if Main_Source_File /= No_Source_File then
Version := Source_Checksum (Main_Source_File);
else
- Error_Msg_File_1 := Fname;
- Error_Msg ("file{ not found", Load_Msg_Sloc);
+ -- To avoid emitting a source location (since there is no file),
+ -- we write a custom error message instead of using the machinery
+ -- in errout.adb.
+
+ Set_Standard_Error;
+ Write_Str ("file """ & Get_Name_String (Fname) & """ not found");
+ Write_Eol;
+ Set_Standard_Output;
end if;
Units.Table (Main_Unit) :=
(Subt, Has_Static_Predicate_Aspect (Par));
Set_Has_Dynamic_Predicate_Aspect
(Subt, Has_Dynamic_Predicate_Aspect (Par));
+
+ -- A named subtype does not inherit the predicate function of its
+ -- parent but an itype declared for a loop index needs the discrete
+ -- predicate information of its parent to execute the loop properly.
+
+ if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
+ Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
+
+ if Has_Static_Predicate (Par) then
+ Set_Static_Discrete_Predicate
+ (Subt, Static_Discrete_Predicate (Par));
+ end if;
+ end if;
end Inherit_Predicate_Flags;
----------------------
elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
Error_Msg_NE -- CODEFIX
- ("(style) missing OVERRIDING indicator in deckaration of&",
+ ("(style) missing OVERRIDING indicator in declaration of&",
Specification (N), E);
else
projects / gcc.git / commitdiff