+2017-01-20 Yannick Moy <moy@adacore.com>
+
+ * sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error
+ on implicitly with'ed units in GNATprove mode.
+ * sinfo.ads (Implicit_With): Document use of flag for implicitly
+ with'ed units in GNATprove mode.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_cat.adb (Validate_Static_Object_Name): In a preelaborated
+ unit Do not report an error on a non-static entity that appears
+ in the context of a spec expression, such as an aspect expression.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb: Flag298 now denotes Is_Underlying_Full_View.
+ (Is_Underlying_Full_View): New routine.
+ (Set_Is_Underlying_Full_View): New routine.
+ (Write_Entity_Flags): Add an entry for Is_Underlying_Full_View.
+ * einfo.ads Add new attribute Is_Underlying_Full_View.
+ (Is_Underlying_Full_View): New routine along with pragma Inline.
+ (Set_Is_Underlying_Full_View): New routine along with pragma Inline.
+ * exp_util.adb (Build_DIC_Procedure_Body): Do not consider
+ class-wide types and underlying full views. The first subtype
+ is used as the working type for all Itypes, not just array base types.
+ (Build_DIC_Procedure_Declaration): Do not consider
+ class-wide types and underlying full views. The first subtype
+ is used as the working type for all Itypes, not just array
+ base types.
+ * freeze.adb (Freeze_Entity): Inherit the freeze node of a full
+ view or an underlying full view without clobbering the attributes
+ of a previous freeze node.
+ (Inherit_Freeze_Node): New routine.
+ * sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying
+ full view as such.
+ (Build_Underlying_Full_View): Mark an underlying full view as such.
+ * sem_ch7.adb (Install_Private_Declarations): Mark an underlying
+ full view as such.
+
2017-01-20 Yannick Moy <moy@adacore.com>
* sinfo.ads: Document lack of Do_Division_Check flag
-- Is_Ignored_Transient Flag295
-- Has_Partial_Visible_Refinement Flag296
-- Is_Entry_Wrapper Flag297
+ -- Is_Underlying_Full_View Flag298
- -- (unused) Flag298
-- (unused) Flag299
-- (unused) Flag300
return Flag117 (Implementation_Base_Type (Id));
end Is_Unchecked_Union;
+ function Is_Underlying_Full_View (Id : E) return B is
+ begin
+ return Flag298 (Id);
+ end Is_Underlying_Full_View;
+
function Is_Underlying_Record_View (Id : E) return B is
begin
return Flag246 (Id);
Set_Flag117 (Id, V);
end Set_Is_Unchecked_Union;
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag298 (Id, V);
+ end Set_Is_Underlying_Full_View;
+
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
W ("Is_Trivial_Subprogram", Flag235 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
+ W ("Is_Underlying_Full_View", Flag298 (Id));
W ("Is_Underlying_Record_View", Flag246 (Id));
W ("Is_Unimplemented", Flag284 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
+-- Is_Underlying_Full_View (Flag298)
+-- Defined in all entities. Set for types which represent the true full
+-- view of a private type completed by another private type. For further
+-- details, see attribute Underlying_Full_View.
+
-- Is_Underlying_Record_View (Flag246) [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
function Is_Trivial_Subprogram (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
+ function Is_Underlying_Full_View (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unimplemented (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unimplemented (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
pragma Inline (Is_True_Constant);
pragma Inline (Is_Type);
pragma Inline (Is_Unchecked_Union);
+ pragma Inline (Is_Underlying_Full_View);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unimplemented);
pragma Inline (Is_Unsigned_Type);
pragma Inline (Set_Is_Trivial_Subprogram);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
+ pragma Inline (Set_Is_Underlying_Full_View);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unimplemented);
pragma Inline (Set_Is_Unsigned_Type);
-- Start of processing for Build_DIC_Procedure_Body
begin
- Work_Typ := Typ;
+ Work_Typ := Base_Type (Typ);
- -- The input type denotes the implementation base type of a constrained
- -- array type. Work with the first subtype as the DIC pragma is on its
- -- rep item chain.
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
- if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
+
+ -- Use the first subtype when dealing with various base types
+
+ elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a
-- The working type
begin
- Work_Typ := Typ;
+ Work_Typ := Base_Type (Typ);
+
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
+
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
- -- The input type denotes the implementation base type of a constrained
- -- array type. Work with the first subtype as the DIC pragma is on its
- -- rep item chain.
+ -- Use the first subtype when dealing with various base types
- if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id);
+ -- Set type Typ's freeze node to refer to Fnode. This routine ensures
+ -- that any attributes attached to Typ's original node are preserved.
+
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
-- then this procedure will create a wrapper to ensure that proper run-
return False;
end Has_Boolean_Aspect_Import;
+ -------------------------
+ -- Inherit_Freeze_Node --
+ -------------------------
+
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id)
+ is
+ Typ_Fnod : constant Node_Id := Freeze_Node (Typ);
+
+ begin
+ Set_Freeze_Node (Typ, Fnod);
+ Set_Entity (Fnod, Typ);
+
+ -- The input type had an existing node. Propagate relevant attributes
+ -- from the old freeze node to the inherited freeze node.
+
+ -- ??? if both freeze nodes have attributes, would they differ?
+
+ if Present (Typ_Fnod) then
+
+ -- Attribute Access_Types_To_Process
+
+ if Present (Access_Types_To_Process (Typ_Fnod))
+ and then No (Access_Types_To_Process (Fnod))
+ then
+ Set_Access_Types_To_Process (Fnod,
+ Access_Types_To_Process (Typ_Fnod));
+ end if;
+
+ -- Attribute Actions
+
+ if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then
+ Set_Actions (Fnod, Actions (Typ_Fnod));
+ end if;
+
+ -- Attribute First_Subtype_Link
+
+ if Present (First_Subtype_Link (Typ_Fnod))
+ and then No (First_Subtype_Link (Fnod))
+ then
+ Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod));
+ end if;
+
+ -- Attribute TSS_Elist
+
+ if Present (TSS_Elist (Typ_Fnod))
+ and then No (TSS_Elist (Fnod))
+ then
+ Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod));
+ end if;
+ end if;
+ end Inherit_Freeze_Node;
+
------------------------------
-- Wrap_Imported_Subprogram --
------------------------------
F_Node := Freeze_Node (Full);
if Present (F_Node) then
- Set_Freeze_Node (Full_View (E), F_Node);
- Set_Entity (F_Node, Full_View (E));
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => Full_View (E));
else
Set_Has_Delayed_Freeze (Full_View (E), False);
Set_Freeze_Node (Full_View (E), Empty);
F_Node := Freeze_Node (Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
F_Node := Freeze_Node (Underlying_Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
-- Error if the name is a primary in an expression. The parent must not
-- be an operator, or a selected component or an indexed component that
-- is itself a primary. Entities that are actuals do not need to be
- -- checked, because the call itself will be diagnosed.
+ -- checked, because the call itself will be diagnosed. Entities in a
+ -- generic unit or within a preanalyzed expression are not checked:
+ -- only their use in executable code matters.
if Is_Primary (N)
and then (not Inside_A_Generic
or else Present (Enclosing_Generic_Body (N)))
+ and then not In_Spec_Expression
then
if Ekind (Entity (N)) = E_Variable
or else Ekind (Entity (N)) in Formal_Object_Kind
if Nkind (CI) = N_With_Clause
and then not
No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI)))
+
+ -- In GNATprove mode, some runtime units are implicitly
+ -- loaded to make their entities available for analysis. In
+ -- this case, ignore violations of No_Elaboration_Code_All
+ -- for this special analysis mode.
+
+ and then not
+ (GNATprove_Mode and then Implicit_With (CI))
then
Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma);
Error_Msg_N
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
if not Is_Base_Type (Derived_Type) then
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
else
Build_Full_Derivation;
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- The full view will be used to swap entities on entry/exit to
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
+ Set_Is_Underlying_Full_View (Full_View (Subt));
end Build_Underlying_Full_View;
-------------------------------
then
Set_Full_View (Id, Underlying_Full_View (Full));
Set_Underlying_Full_View (Id, Full);
+ Set_Is_Underlying_Full_View (Full);
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));
-- Implicit_With (Flag16-Sem)
-- This flag is set in the N_With_Clause node that is implicitly
- -- generated for runtime units that are loaded by the expander, and also
- -- for package System, if it is loaded implicitly by a use of the
- -- 'Address or 'Tag attribute. ???There are other implicit with clauses
- -- as well.
+ -- generated for runtime units that are loaded by the expander or in
+ -- GNATprove mode, and also for package System, if it is loaded
+ -- implicitly by a use of the 'Address or 'Tag attribute.
+ -- ??? There are other implicit with clauses as well.
-- Implicit_With_From_Instantiation (Flag12-Sem)
-- Set in N_With_Clause nodes from generic instantiations.
-- actuals to support a build-in-place style of call have been added to
-- the call.
- -- Is_Finalization_Wrapper (Flag9-Sem);
+ -- Is_Finalization_Wrapper (Flag9-Sem)
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- objects. The wrapper prevents interference between exception handlers
-- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
-- has been constant-folded into its literal value.
-- Intval (Uint3) contains integer value of literal
- -- plus fields for expression
-- Print_In_Hex (Flag13-Sem)
+ -- plus fields for expression
-- N_Real_Literal
-- Sloc points to literal
-- N_Discriminant_Association
-- Sloc points to first token of discriminant association
-- Selector_Names (List1) (always non-empty, since if no selector
- -- names are present, this node is not used, see comment above)
+ -- names are present, this node is not used, see comment above)
-- Expression (Node3)
---------------------------------
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
-- plus fields for expression
-- N_Op_Expon
- -- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- Sloc points to **
+ -- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- plus fields for binary operator
-- plus fields for expression
-- Sloc points to apostrophe
-- Subtype_Mark (Node4)
-- Expression (Node3) expression or aggregate
- -- plus fields for expression
-- Is_Qualified_Universal_Literal (Flag4-Sem)
+ -- plus fields for expression
--------------------
-- 4.8 Allocator --
projects / gcc.git / commitdiff