+ if not (Present (Component_List (Ext))) then
+ Set_Null_Present (Ext, False);
+ L := New_List;
+ Set_Component_List (Ext,
+ Make_Component_List (Loc,
+ Component_Items => L,
+ Null_Present => False));
+ else
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+ L := Component_Items
+ (Component_List
+ (Record_Extension_Part
+ (Type_Definition (N))));
+ else
+ L := Component_Items
+ (Component_List
+ (Type_Definition (N)));
+ end if;
+
+ -- Find the last tag component
+
+ Comp := First (L);
+ while Present (Comp) loop
+ if Is_Tag (Defining_Identifier (Comp)) then
+ Last_Tag := Comp;
+ end if;
+
+ Next (Comp);
+ end loop;
+ end if;
+
+ -- At this point L references the list of components and Last_Tag
+ -- references the current last tag (if any). Now we add the tag
+ -- corresponding with all the interfaces that are not implemented
+ -- by the parent.
+
+ pragma Assert (Present
+ (First_Elmt (Abstract_Interfaces (Typ))));
+
+ Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (Elmt) loop
+ Add_Tag (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end Add_Interface_Tag_Components;
+
+ -----------------------------------
+ -- Analyze_Component_Declaration --
+ -----------------------------------
+
+ procedure Analyze_Component_Declaration (N : Node_Id) is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ P : Entity_Id;
+
+ function Contains_POC (Constr : Node_Id) return Boolean;
+ -- Determines whether a constraint uses the discriminant of a record
+ -- type thus becoming a per-object constraint (POC).
+
+ function Is_Known_Limited (Typ : Entity_Id) return Boolean;
+ -- Typ is the type of the current component, check whether this type is
+ -- a limited type. Used to validate declaration against that of
+ -- enclosing record.
+
+ ------------------
+ -- Contains_POC --
+ ------------------
+
+ function Contains_POC (Constr : Node_Id) return Boolean is
+ begin
+ case Nkind (Constr) is
+ when N_Attribute_Reference =>
+ return Attribute_Name (Constr) = Name_Access
+ and
+ Prefix (Constr) = Scope (Entity (Prefix (Constr)));
+
+ when N_Discriminant_Association =>
+ return Denotes_Discriminant (Expression (Constr));
+
+ when N_Identifier =>
+ return Denotes_Discriminant (Constr);
+
+ when N_Index_Or_Discriminant_Constraint =>
+ declare
+ IDC : Node_Id;
+
+ begin
+ IDC := First (Constraints (Constr));
+ while Present (IDC) loop
+
+ -- One per-object constraint is sufficient
+
+ if Contains_POC (IDC) then
+ return True;
+ end if;
+
+ Next (IDC);
+ end loop;
+
+ return False;
+ end;
+
+ when N_Range =>
+ return Denotes_Discriminant (Low_Bound (Constr))
+ or else
+ Denotes_Discriminant (High_Bound (Constr));
+
+ when N_Range_Constraint =>
+ return Denotes_Discriminant (Range_Expression (Constr));
+
+ when others =>
+ return False;
+
+ end case;
+ end Contains_POC;
+
+ ----------------------
+ -- Is_Known_Limited --
+ ----------------------
+
+ function Is_Known_Limited (Typ : Entity_Id) return Boolean is
+ P : constant Entity_Id := Etype (Typ);
+ R : constant Entity_Id := Root_Type (Typ);
+
+ begin
+ if Is_Limited_Record (Typ) then
+ return True;
+
+ -- If the root type is limited (and not a limited interface)
+ -- so is the current type
+
+ elsif Is_Limited_Record (R)
+ and then
+ (not Is_Interface (R)
+ or else not Is_Limited_Interface (R))
+ then
+ return True;
+
+ -- Else the type may have a limited interface progenitor, but a
+ -- limited record parent.
+
+ elsif R /= P
+ and then Is_Limited_Record (P)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Known_Limited;
+
+ -- Start of processing for Analyze_Component_Declaration
+
+ begin
+ Generate_Definition (Id);
+ Enter_Name (Id);
+
+ if Present (Subtype_Indication (Component_Definition (N))) then
+ T := Find_Type_Of_Object
+ (Subtype_Indication (Component_Definition (N)), N);
+
+ -- Ada 2005 (AI-230): Access Definition case
+
+ else
+ pragma Assert (Present
+ (Access_Definition (Component_Definition (N))));
+
+ T := Access_Definition
+ (Related_Nod => N,
+ N => Access_Definition (Component_Definition (N)));
+ Set_Is_Local_Anonymous_Access (T);
+
+ -- Ada 2005 (AI-254)
+
+ if Present (Access_To_Subprogram_Definition
+ (Access_Definition (Component_Definition (N))))
+ and then Protected_Present (Access_To_Subprogram_Definition
+ (Access_Definition
+ (Component_Definition (N))))
+ then
+ T := Replace_Anonymous_Access_To_Protected_Subprogram (N, T);
+ end if;
+ end if;
+
+ -- If the subtype is a constrained subtype of the enclosing record,
+ -- (which must have a partial view) the back-end does not properly
+ -- handle the recursion. Rewrite the component declaration with an
+ -- explicit subtype indication, which is acceptable to Gigi. We can copy
+ -- the tree directly because side effects have already been removed from
+ -- discriminant constraints.
+
+ if Ekind (T) = E_Access_Subtype
+ and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
+ and then Comes_From_Source (T)
+ and then Nkind (Parent (T)) = N_Subtype_Declaration
+ and then Etype (Directly_Designated_Type (T)) = Current_Scope
+ then
+ Rewrite
+ (Subtype_Indication (Component_Definition (N)),
+ New_Copy_Tree (Subtype_Indication (Parent (T))));
+ T := Find_Type_Of_Object
+ (Subtype_Indication (Component_Definition (N)), N);
+ end if;
+
+ -- If the component declaration includes a default expression, then we
+ -- check that the component is not of a limited type (RM 3.7(5)),
+ -- and do the special preanalysis of the expression (see section on
+ -- "Handling of Default and Per-Object Expressions" in the spec of
+ -- package Sem).
+
+ if Present (Expression (N)) then
+ Analyze_Per_Use_Expression (Expression (N), T);
+ Check_Initialization (T, Expression (N));
+
+ if Ada_Version >= Ada_05
+ and then Is_Access_Type (T)
+ and then Ekind (T) = E_Anonymous_Access_Type
+ then
+ -- Check RM 3.9.2(9): "if the expected type for an expression is
+ -- an anonymous access-to-specific tagged type, then the object
+ -- designated by the expression shall not be dynamically tagged
+ -- unless it is a controlling operand in a call on a dispatching
+ -- operation"
+
+ if Is_Tagged_Type (Directly_Designated_Type (T))
+ and then
+ Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
+ and then
+ Ekind (Directly_Designated_Type (Etype (Expression (N)))) =
+ E_Class_Wide_Type
+ then
+ Error_Msg_N
+ ("access to specific tagged type required ('R'M 3.9.2(9))",
+ Expression (N));
+ end if;
+
+ -- (Ada 2005: AI-230): Accessibility check for anonymous
+ -- components
+
+ -- Missing barrier Ada_Version >= Ada_05???
+
+ if Type_Access_Level (Etype (Expression (N))) >
+ Type_Access_Level (T)
+ then
+ Error_Msg_N
+ ("expression has deeper access level than component " &
+ "('R'M 3.10.2 (12.2))", Expression (N));
+ end if;
+ end if;
+ end if;
+
+ -- The parent type may be a private view with unknown discriminants,
+ -- and thus unconstrained. Regular components must be constrained.
+
+ if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
+ if Is_Class_Wide_Type (T) then
+ Error_Msg_N
+ ("class-wide subtype with unknown discriminants" &
+ " in component declaration",
+ Subtype_Indication (Component_Definition (N)));
+ else
+ Error_Msg_N
+ ("unconstrained subtype in component declaration",
+ Subtype_Indication (Component_Definition (N)));
+ end if;
+
+ -- Components cannot be abstract, except for the special case of
+ -- the _Parent field (case of extending an abstract tagged type)
+
+ elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
+ Error_Msg_N ("type of a component cannot be abstract", N);
+ end if;
+
+ Set_Etype (Id, T);
+ Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
+
+ -- The component declaration may have a per-object constraint, set
+ -- the appropriate flag in the defining identifier of the subtype.
+
+ if Present (Subtype_Indication (Component_Definition (N))) then
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (N));
+
+ begin
+ if Nkind (Sindic) = N_Subtype_Indication
+ and then Present (Constraint (Sindic))
+ and then Contains_POC (Constraint (Sindic))
+ then
+ Set_Has_Per_Object_Constraint (Id);
+ end if;
+ end;
+ end if;
+
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
+ -- out some static checks.
+
+ if Ada_Version >= Ada_05
+ and then Can_Never_Be_Null (T)
+ then
+ Null_Exclusion_Static_Checks (N);
+ end if;
+
+ -- If this component is private (or depends on a private type), flag the
+ -- record type to indicate that some operations are not available.
+
+ P := Private_Component (T);
+
+ if Present (P) then
+
+ -- Check for circular definitions
+
+ if P = Any_Type then
+ Set_Etype (Id, Any_Type);
+
+ -- There is a gap in the visibility of operations only if the
+ -- component type is not defined in the scope of the record type.
+
+ elsif Scope (P) = Scope (Current_Scope) then
+ null;
+
+ elsif Is_Limited_Type (P) then
+ Set_Is_Limited_Composite (Current_Scope);
+
+ else
+ Set_Is_Private_Composite (Current_Scope);
+ end if;
+ end if;
+
+ if P /= Any_Type
+ and then Is_Limited_Type (T)
+ and then Chars (Id) /= Name_uParent
+ and then Is_Tagged_Type (Current_Scope)
+ then
+ if Is_Derived_Type (Current_Scope)
+ and then not Is_Known_Limited (Current_Scope)
+ then
+ Error_Msg_N
+ ("extension of nonlimited type cannot have limited components",
+ N);
+
+ if Is_Interface (Root_Type (Current_Scope)) then
+ Error_Msg_N
+ ("\limitedness is not inherited from limited interface", N);
+ Error_Msg_N
+ ("\add LIMITED to type indication", N);
+ end if;
+
+ Explain_Limited_Type (T, N);
+ Set_Etype (Id, Any_Type);
+ Set_Is_Limited_Composite (Current_Scope, False);
+
+ elsif not Is_Derived_Type (Current_Scope)
+ and then not Is_Limited_Record (Current_Scope)
+ and then not Is_Concurrent_Type (Current_Scope)
+ then
+ Error_Msg_N
+ ("nonlimited tagged type cannot have limited components", N);
+ Explain_Limited_Type (T, N);
+ Set_Etype (Id, Any_Type);
+ Set_Is_Limited_Composite (Current_Scope, False);
+ end if;
+ end if;
+
+ Set_Original_Record_Component (Id, Id);
+ end Analyze_Component_Declaration;
+
+ --------------------------
+ -- Analyze_Declarations --
+ --------------------------
+
+ procedure Analyze_Declarations (L : List_Id) is
+ D : Node_Id;
+ Freeze_From : Entity_Id := Empty;
+ Next_Node : Node_Id;
+
+ procedure Adjust_D;
+ -- Adjust D not to include implicit label declarations, since these
+ -- have strange Sloc values that result in elaboration check problems.
+ -- (They have the sloc of the label as found in the source, and that
+ -- is ahead of the current declarative part).
+
+ --------------
+ -- Adjust_D --
+ --------------
+
+ procedure Adjust_D is
+ begin
+ while Present (Prev (D))
+ and then Nkind (D) = N_Implicit_Label_Declaration
+ loop
+ Prev (D);
+ end loop;
+ end Adjust_D;
+
+ -- Start of processing for Analyze_Declarations
+
+ begin
+ D := First (L);
+ while Present (D) loop
+
+ -- Complete analysis of declaration
+
+ Analyze (D);
+ Next_Node := Next (D);
+
+ if No (Freeze_From) then
+ Freeze_From := First_Entity (Current_Scope);
+ end if;
+
+ -- At the end of a declarative part, freeze remaining entities
+ -- declared in it. The end of the visible declarations of package
+ -- specification is not the end of a declarative part if private
+ -- declarations are present. The end of a package declaration is a
+ -- freezing point only if it a library package. A task definition or
+ -- protected type definition is not a freeze point either. Finally,
+ -- we do not freeze entities in generic scopes, because there is no
+ -- code generated for them and freeze nodes will be generated for
+ -- the instance.
+
+ -- The end of a package instantiation is not a freeze point, but
+ -- for now we make it one, because the generic body is inserted