Error_Msg_N ("task entries cannot have access parameters", N);
end if;
+ -- Ada 2005 (AI-254): In case of anonymous access to subprograms
+ -- call the corresponding semantic routine
+
+ if Present (Access_To_Subprogram_Definition (N)) then
+ Access_Subprogram_Declaration
+ (T_Name => Anon_Type,
+ T_Def => Access_To_Subprogram_Definition (N));
+
+ if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
+ Set_Ekind
+ (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
+ else
+ Set_Ekind
+ (Anon_Type, E_Anonymous_Access_Subprogram_Type);
+ end if;
+
+ return Anon_Type;
+ end if;
+
Find_Type (Subtype_Mark (N));
Desig_Type := Entity (Subtype_Mark (N));
Init_Size_Align (Anon_Type);
Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
+ -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
+ -- from Ada 95 semantics. In Ada 2005, anonymous access must specify
+ -- if the null value is allowed. In Ada 95 the null value is never
+ -- allowed.
+
+ if Ada_Version >= Ada_05 then
+ Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
+ else
+ Set_Can_Never_Be_Null (Anon_Type, True);
+ end if;
+
-- The anonymous access type is as public as the discriminated type or
-- subprogram that defines it. It is imported (for back-end purposes)
-- if the designated type is.
- Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
+ Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
- -- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
+ -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
- Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
+ Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
+
+ -- Ada 2005 (AI-231): Propagate the access-constant attribute
+
+ Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
-- The context is either a subprogram declaration or an access
-- discriminant, in a private or a full type declaration. In
-- the case of a subprogram, If the designated type is incomplete,
-- the operation will be a primitive operation of the full type, to
- -- be updated subsequently.
+ -- be updated subsequently. If the type is imported through a limited
+ -- with clause, it is not a primitive operation of the type (which
+ -- is declared elsewhere in some other scope).
if Ekind (Desig_Type) = E_Incomplete_Type
+ and then not From_With_Type (Desig_Type)
and then Is_Overloadable (Current_Scope)
then
Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
Formal : Entity_Id;
Desig_Type : constant Entity_Id :=
- Create_Itype (E_Subprogram_Type, Parent (T_Def));
+ Create_Itype (E_Subprogram_Type, Parent (T_Def));
begin
if Nkind (T_Def) = N_Access_Function_Definition then
Init_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute
+
+ Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
+
Check_Restriction (No_Access_Subprograms, T_Def);
end Access_Subprogram_Declaration;
Desig : Entity_Id;
-- Designated type
- N_Desig : Entity_Id;
- -- Non-limited view, when needed
-
begin
-- Check for permissible use of incomplete type
-- access type is also imported, and therefore restricted in its use.
-- The access type may already be imported, so keep setting otherwise.
- -- Ada 0Y (AI-50217): If the non-limited view of the designated type is
- -- available, use it as the designated type of the access type, so that
- -- the back-end gets a usable entity.
+ -- Ada 2005 (AI-50217): If the non-limited view of the designated type
+ -- is available, use it as the designated type of the access type, so
+ -- that the back-end gets a usable entity.
+
+ declare
+ N_Desig : Entity_Id;
- if From_With_Type (Desig) then
- Set_From_With_Type (T);
+ begin
+ if From_With_Type (Desig) then
+ Set_From_With_Type (T);
- if Ekind (Desig) = E_Incomplete_Type then
- N_Desig := Non_Limited_View (Desig);
+ if Ekind (Desig) = E_Incomplete_Type then
+ N_Desig := Non_Limited_View (Desig);
- elsif Ekind (Desig) = E_Class_Wide_Type then
- if From_With_Type (Etype (Desig)) then
- N_Desig := Non_Limited_View (Etype (Desig));
- else
- N_Desig := Etype (Desig);
+ else pragma Assert (Ekind (Desig) = E_Class_Wide_Type);
+ if From_With_Type (Etype (Desig)) then
+ N_Desig := Non_Limited_View (Etype (Desig));
+ else
+ N_Desig := Etype (Desig);
+ end if;
end if;
- else
- null;
- pragma Assert (False);
- end if;
- pragma Assert (Present (N_Desig));
- Set_Directly_Designated_Type (T, N_Desig);
- end if;
+ pragma Assert (Present (N_Desig));
+ Set_Directly_Designated_Type (T, N_Desig);
+ end if;
+ end;
-- Note that Has_Task is always false, since the access type itself
-- is not a task type. See Einfo for more description on this point.
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
+
+ -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
+ -- attributes
+
+ Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def));
+ Set_Is_Access_Constant (T, Constant_Present (Def));
end Access_Type_Declaration;
-----------------------------------
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).
+
+ ------------------
+ -- 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 := First (Constraints (Constr));
+ begin
+ while Present (IDC) loop
+
+ -- One per-object constraint is sufficent
+
+ 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
+ Denotes_Discriminant (High_Bound (Constr));
+
+ when N_Range_Constraint =>
+ return Denotes_Discriminant (Range_Expression (Constr));
+
+ when others =>
+ return False;
+
+ end case;
+ end Contains_POC;
+
+ -- Start of processing for Analyze_Component_Declaration
+
begin
Generate_Definition (Id);
Enter_Name (Id);
T := Find_Type_Of_Object
(Subtype_Indication (Component_Definition (N)), N);
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
+
+ else
+ pragma Assert (Present
+ (Access_Definition (Component_Definition (N))));
- elsif Present (Access_Definition (Component_Definition (N))) then
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
- else
- pragma Assert (False);
- null;
+ -- Ada 2005 (AI-230): In case of components that are anonymous
+ -- access types the level of accessibility depends on the enclosing
+ -- type declaration
+
+ Set_Scope (T, Current_Scope); -- Ada 2005 (AI-230)
+
+ -- 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,
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 (Null_Exclusion_Present (Component_Definition (N))
+ or else Can_Never_Be_Null (T))
+ then
+ Set_Can_Never_Be_Null (Id);
+ 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.
-- appear in the private part of a package, for a private type that has
-- already been declared.
- -- In this case, the discriminants (if any) must match.
+ -- In this case, the discriminants (if any) must match
T := Find_Type_Name (N);
end if;
end if;
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
+ -- out some static checks
+
+ if Ada_Version >= Ada_05
+ and then (Null_Exclusion_Present (N)
+ or else Can_Never_Be_Null (T))
+ then
+ Set_Can_Never_Be_Null (Id);
+ Null_Exclusion_Static_Checks (N);
+ end if;
+
Set_Is_Pure (Id, Is_Pure (Current_Scope));
-- If deferred constant, make sure context is appropriate. We detect
-- In Ada 83, deferred constant must be of private type
elsif not Is_Private_Type (T) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) deferred constant must be private type", N);
end if;
if Present (E) and then E /= Error then
Analyze (E);
+ -- In case of errors detected in the analysis of the expression,
+ -- decorate it with the expected type to avoid cascade errors
+
+ if not Present (Etype (E)) then
+ Set_Etype (E, T);
+ end if;
+
-- If an initialization expression is present, then we set the
-- Is_True_Constant flag. It will be reset if this is a variable
-- and it is indeed modified.
Set_Is_True_Constant (Id, True);
+ -- If we are analyzing a constant declaration, set its completion
+ -- flag after analyzing the expression.
+
+ if Constant_Present (N) then
+ Set_Has_Completion (Id);
+ end if;
+
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
-- Not allowed in Ada 83
if not Constant_Present (N) then
- if Ada_83
+ if Ada_Version = Ada_83
and then Comes_From_Source (Object_Definition (N))
then
Error_Msg_N
Set_Is_First_Subtype (T);
Make_Class_Wide_Type (T);
+ if Unknown_Discriminants_Present (N) then
+ Set_Discriminant_Constraint (T, No_Elist);
+ end if;
+
Build_Derived_Record_Type (N, Parent_Type, T);
end Analyze_Private_Extension_Declaration;
Set_Directly_Designated_Type
(Id, Designated_Type (T));
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute
+ -- and carry out some static checks
+
+ if Null_Exclusion_Present (N)
+ or else Can_Never_Be_Null (T)
+ then
+ Set_Can_Never_Be_Null (Id);
+
+ if Null_Exclusion_Present (N)
+ and then Can_Never_Be_Null (T)
+ then
+ Error_Msg_N
+ ("(Ada 2005) null exclusion not allowed if parent "
+ & "is already non-null", Subtype_Indication (N));
+ end if;
+ end if;
+
-- A Pure library_item must not contain the declaration of a
-- named access type, except within a subprogram, generic
-- subprogram, task unit, or protected unit (RM 10.2.1(16)).
-- The full view, if present, now points to the current type
- -- Ada 0Y (AI-50217): If the type was previously decorated when imported
- -- through a LIMITED WITH clause, it appears as incomplete but has no
- -- full view.
+ -- Ada 2005 (AI-50217): If the type was previously decorated when
+ -- imported through a LIMITED WITH clause, it appears as incomplete
+ -- but has no full view.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
P, Related_Id, 'C');
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-230): Access Definition case
- elsif Present (Access_Definition (Component_Def)) then
+ else pragma Assert (Present (Access_Definition (Component_Def)));
Element_Type := Access_Definition
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
- else
- pragma Assert (False);
- null;
+ -- Ada 2005 (AI-230): In case of components that are anonymous
+ -- access types the level of accessibility depends on the enclosing
+ -- type declaration
+
+ Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
+
+ -- Ada 2005 (AI-254)
+
+ declare
+ CD : constant Node_Id :=
+ Access_To_Subprogram_Definition
+ (Access_Definition (Component_Def));
+ begin
+ if Present (CD) and then Protected_Present (CD) then
+ Element_Type :=
+ Replace_Anonymous_Access_To_Protected_Subprogram
+ (Def, Element_Type);
+ end if;
+ end;
end if;
-- Constrained array case
Set_Has_Aliased_Components (Etype (T));
end if;
+ -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
+ -- array to ensure that objects of this type are initialized.
+
+ if Ada_Version >= Ada_05
+ and then (Null_Exclusion_Present (Component_Definition (Def))
+ or else Can_Never_Be_Null (Element_Type))
+ then
+ Set_Can_Never_Be_Null (T);
+
+ if Null_Exclusion_Present (Component_Definition (Def))
+ and then Can_Never_Be_Null (Element_Type)
+ then
+ Error_Msg_N
+ ("(Ada 2005) already a null-excluding type",
+ Subtype_Indication (Component_Definition (Def)));
+ end if;
+ end if;
+
Priv := Private_Component (Element_Type);
if Present (Priv) then
end Array_Type_Declaration;
+ ------------------------------------------------------
+ -- Replace_Anonymous_Access_To_Protected_Subprogram --
+ ------------------------------------------------------
+
+ function Replace_Anonymous_Access_To_Protected_Subprogram
+ (N : Node_Id;
+ Prev_E : Entity_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Curr_Scope : constant Scope_Stack_Entry :=
+ Scope_Stack.Table (Scope_Stack.Last);
+
+ Anon : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+
+ Acc : Node_Id;
+ Comp : Node_Id;
+ Decl : Node_Id;
+ P : Node_Id := Parent (N);
+
+ begin
+ Set_Is_Internal (Anon);
+
+ case Nkind (N) is
+ when N_Component_Declaration |
+ N_Unconstrained_Array_Definition |
+ N_Constrained_Array_Definition =>
+ Comp := Component_Definition (N);
+ Acc := Access_Definition (Component_Definition (N));
+
+ when N_Discriminant_Specification =>
+ Comp := Discriminant_Type (N);
+ Acc := Discriminant_Type (N);
+
+ when N_Parameter_Specification =>
+ Comp := Parameter_Type (N);
+ Acc := Parameter_Type (N);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon,
+ Type_Definition =>
+ Copy_Separate_Tree (Access_To_Subprogram_Definition (Acc)));
+
+ Mark_Rewrite_Insertion (Decl);
+
+ -- Insert the new declaration in the nearest enclosing scope
+
+ while Present (P) and then not Has_Declarations (P) loop
+ P := Parent (P);
+ end loop;
+
+ pragma Assert (Present (P));
+
+ if Nkind (P) = N_Package_Specification then
+ Prepend (Decl, Visible_Declarations (P));
+ else
+ Prepend (Decl, Declarations (P));
+ end if;
+
+ -- Replace the anonymous type with an occurrence of the new declaration.
+ -- In all cases the rewriten node does not have the null-exclusion
+ -- attribute because (if present) it was already inherited by the
+ -- anonymous entity (Anon). Thus, in case of components we do not
+ -- inherit this attribute.
+
+ if Nkind (N) = N_Parameter_Specification then
+ Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
+ Set_Etype (Defining_Identifier (N), Anon);
+ Set_Null_Exclusion_Present (N, False);
+ else
+ Rewrite (Comp,
+ Make_Component_Definition (Loc,
+ Subtype_Indication => New_Occurrence_Of (Anon, Loc)));
+ end if;
+
+ Mark_Rewrite_Insertion (Comp);
+
+ -- Temporarily remove the current scope from the stack to add the new
+ -- declarations to the enclosing scope
+
+ Scope_Stack.Decrement_Last;
+ Analyze (Decl);
+ Scope_Stack.Append (Curr_Scope);
+
+ Set_Original_Access_Type (Anon, Prev_E);
+ return Anon;
+ end Replace_Anonymous_Access_To_Protected_Subprogram;
+
-------------------------------
-- Build_Derived_Access_Type --
-------------------------------
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
+ -- Ada 2005 (AI-231). Set the null-exclusion attribute
+
+ if Null_Exclusion_Present (Type_Definition (N))
+ or else Can_Never_Be_Null (Parent_Type)
+ then
+ Set_Can_Never_Be_Null (Derived_Type);
+ end if;
+
-- Note: we do not copy the Storage_Size_Variable, since
-- we always go to the root type for this information.
else
Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
if Has_Discriminants (Parent_Type) then
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Discriminant_Constraint (
Derived_Type, Discriminant_Constraint (Parent_Type));
end if;
-- Copy declaration for subsequent analysis, to
-- provide a completion for what is a private
- -- declaration.
+ -- declaration. Indicate that the full type is
+ -- internally generated.
Full_Decl := New_Copy_Tree (N);
Full_Der := New_Copy (Derived_Type);
+ Set_Comes_From_Source (Full_Decl, False);
Insert_After (N, Full_Decl);
Set_First_Entity (Derived_Type, First_Entity (Der_Base));
Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
+ Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
else
-- If this is a completion, the derived type stays private
-- discriminants in R and T1 through T4.
-- Type Discrim Stored Discrim Comment
- -- R (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in R
- -- T1 (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in T1
- -- T2 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T2
- -- T3 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T3
- -- T4 (Y) (D1, D2, D3) Gider discrims are EXPLICIT in T4
-
- -- Field Corresponding_Discriminant (abbreviated CD below) allows to find
- -- the corresponding discriminant in the parent type, while
+ -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R
+ -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1
+ -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2
+ -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3
+ -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4
+
+ -- Field Corresponding_Discriminant (abbreviated CD below) allows us to
+ -- find the corresponding discriminant in the parent type, while
-- Original_Record_Component (abbreviated ORC below), the actual physical
-- component that is renamed. Finally the field Is_Completely_Hidden
-- (abbreviated ICH below) is set for all explicit stored discriminants
Next_Discriminant (Discrim);
end loop;
+
+ -- Check whether the constraints of the full view statically
+ -- match those imposed by the parent subtype [7.3(13)].
+
+ if Present (Stored_Constraint (Derived_Type)) then
+ declare
+ C1, C2 : Elmt_Id;
+
+ begin
+ C1 := First_Elmt (Discs);
+ C2 := First_Elmt (Stored_Constraint (Derived_Type));
+ while Present (C1) and then Present (C2) loop
+ if not
+ Fully_Conformant_Expressions (Node (C1), Node (C2))
+ then
+ Error_Msg_N (
+ "not conformant with previous declaration",
+ Node (C1));
+ end if;
+
+ Next_Elmt (C1);
+ Next_Elmt (C2);
+ end loop;
+ end;
+ end if;
end if;
-- STEP 2b: No new discriminants, inherit discriminants if any
else
if Private_Extension then
Set_Has_Unknown_Discriminants
- (Derived_Type, Has_Unknown_Discriminants (Parent_Type)
- or else Unknown_Discriminants_Present (N));
+ (Derived_Type,
+ Has_Unknown_Discriminants (Parent_Type)
+ or else Unknown_Discriminants_Present (N));
-- The partial view of the parent may have unknown discriminants,
-- but if the full view has discriminants and the parent type is
Set_Discriminant_Constraint
(Derived_Type, Save_Discr_Constr);
Set_Stored_Constraint
- (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
+ (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
end if;
end loop;
-- Build an element list consisting of the expressions given in the
- -- discriminant constraint and apply the appropriate range
- -- checks. The list is constructed after resolving any named
- -- discriminant associations and therefore the expressions appear in
- -- the textual order of the discriminants.
+ -- discriminant constraint and apply the appropriate checks. The list
+ -- is constructed after resolving any named discriminant associations
+ -- and therefore the expressions appear in the textual order of the
+ -- discriminants.
Discr := First_Discriminant (T);
for J in Discr_Expr'Range loop
then
null;
+ elsif Is_Access_Type (Etype (Discr)) then
+ Apply_Constraint_Check (Discr_Expr (J), Etype (Discr));
+
else
Apply_Range_Check (Discr_Expr (J), Etype (Discr));
end if;
Set_Ekind (Def_Id, E_Class_Wide_Subtype);
else
- -- Incomplete type. Attach subtype to list of dependents, to be
- -- completed with full view of parent type.
+ -- Incomplete type. attach subtype to list of dependents, to be
+ -- completed with full view of parent type, unless is it the
+ -- designated subtype of a record component within an init_proc.
+ -- This last case arises for a component of an access type whose
+ -- designated type is incomplete (e.g. a Taft Amendment type).
+ -- The designated subtype is within an inner scope, and needs no
+ -- elaboration, because only the access type is needed in the
+ -- initialization procedure.
Set_Ekind (Def_Id, Ekind (T));
- Append_Elmt (Def_Id, Private_Dependents (T));
+
+ if For_Access and then Within_Init_Proc then
+ null;
+ else
+ Append_Elmt (Def_Id, Private_Dependents (T));
+ end if;
end if;
Set_Etype (Def_Id, T);
C : Node_Id;
Id : Node_Id;
+ procedure Set_Discriminant_Name (Id : Node_Id);
+ -- If the derived type has discriminants, they may rename discriminants
+ -- of the parent. When building the full view of the parent, we need to
+ -- recover the names of the original discriminants if the constraint is
+ -- given by named associations.
+
+ ---------------------------
+ -- Set_Discriminant_Name --
+ ---------------------------
+
+ procedure Set_Discriminant_Name (Id : Node_Id) is
+ Disc : Entity_Id;
+
+ begin
+ Set_Original_Discriminant (Id, Empty);
+
+ if Has_Discriminants (Typ) then
+ Disc := First_Discriminant (Typ);
+
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Id)
+ and then Present (Corresponding_Discriminant (Disc))
+ then
+ Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
+ end if;
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ end Set_Discriminant_Name;
+
+ -- Start of processing for Build_Underlying_Full_View
+
begin
if Nkind (N) = N_Full_Type_Declaration then
Constr := Constraint (Subtype_Indication (Type_Definition (N)));
- -- ??? ??? is this assert right, I assume so otherwise Constr
- -- would not be defined below (this used to be an elsif)
-
- else pragma Assert (Nkind (N) = N_Subtype_Declaration);
+ elsif Nkind (N) = N_Subtype_Declaration then
Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
- end if;
- -- If the constraint has discriminant associations, the discriminant
- -- entity is already set, but it denotes a discriminant of the new
- -- type, not the original parent, so it must be found anew.
+ elsif Nkind (N) = N_Component_Declaration then
+ Constr :=
+ New_Copy_Tree
+ (Constraint (Subtype_Indication (Component_Definition (N))));
- C := First (Constraints (Constr));
+ else
+ raise Program_Error;
+ end if;
+ C := First (Constraints (Constr));
while Present (C) loop
-
if Nkind (C) = N_Discriminant_Association then
Id := First (Selector_Names (C));
-
while Present (Id) loop
- Set_Original_Discriminant (Id, Empty);
+ Set_Discriminant_Name (Id);
Next (Id);
end loop;
end if;
Next (C);
end loop;
- Indic := Make_Subtype_Declaration (Loc,
- Defining_Identifier => Subt,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (Par, Loc),
- Constraint => New_Copy_Tree (Constr)));
+ Indic :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Par, Loc),
+ Constraint => New_Copy_Tree (Constr)));
+
+ -- If this is a component subtype for an outer itype, it is not
+ -- a list member, so simply set the parent link for analysis: if
+ -- the enclosing type does not need to be in a declarative list,
+ -- neither do the components.
+
+ if Is_List_Member (N)
+ and then Nkind (N) /= N_Component_Declaration
+ then
+ Insert_Before (N, Indic);
+ else
+ Set_Parent (Indic, Parent (N));
+ end if;
- Insert_Before (N, Indic);
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
end Build_Underlying_Full_View;
and then not In_Instance
and then not In_Inlined_Body
then
- -- Ada 0Y (AI-287): Relax the strictness of the front-end in case of
- -- limited aggregates and extension aggregates.
+ -- Ada 2005 (AI-287): Relax the strictness of the front-end in
+ -- case of limited aggregates and extension aggregates.
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then (Nkind (Exp) = N_Aggregate
- or else Nkind (Exp) = N_Extension_Aggregate)
+ or else Nkind (Exp) = N_Extension_Aggregate)
then
null;
else
Set_Is_Immediately_Visible (D);
Set_Homonym (D, Prev);
- -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
- -- record types
+ -- Ada 2005 (AI-230): Access discriminant allowed in
+ -- non-limited record types.
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
-- This restriction gets applied to the full type here; it
-- has already been applied earlier to the partial view
if Has_Discriminants (Full_Base) then
Set_Discriminant_Constraint
(Full, Discriminant_Constraint (Full_Base));
+
+ -- The partial view may have been indefinite, the full view
+ -- might not be.
+
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
end if;
end if;
if Ekind (Full_Base) = E_Record_Type
and then Has_Discriminants (Full_Base)
and then Has_Discriminants (Priv) -- might not, if errors
+ and then not Has_Unknown_Discriminants (Priv)
and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
then
Create_Constrained_Components
(Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
-- If the full base is itself derived from private, build a congruent
- -- subtype of its underlying type, for use by the back end.
+ -- subtype of its underlying type, for use by the back end. For a
+ -- constrained record component, the declaration cannot be placed on
+ -- the component list, but it must neverthess be built an analyzed, to
+ -- supply enough information for gigi to compute the size of component.
elsif Ekind (Full_Base) in Private_Kind
and then Is_Derived_Type (Full_Base)
and then Has_Discriminants (Full_Base)
- and then
- Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ and then (Ekind (Current_Scope) /= E_Record_Subtype)
then
- Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
+ if not Is_Itype (Priv)
+ and then
+ Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View
+ (Parent (Priv), Full, Etype (Full_Base));
+
+ elsif Nkind (Related_Nod) = N_Component_Declaration then
+ Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
+ end if;
elsif Is_Record_Type (Full_Base) then
Make_Subtype_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Indication => Indic);
+
Set_Parent (Subtyp_Decl, Parent (Related_Node));
-- Itypes must be analyzed with checks off (see itypes.ads).
Suffix : Character;
Suffix_Index : Nat)
is
- Def_Id : Entity_Id;
- R : Node_Id := Empty;
- Checks_Off : Boolean := False;
- T : constant Entity_Id := Etype (Index);
+ Def_Id : Entity_Id;
+ R : Node_Id := Empty;
+ T : constant Entity_Id := Etype (Index);
begin
if Nkind (S) = N_Range
Set_Etype (S, T);
R := S;
- -- ??? Why on earth do we turn checks of in this very specific case ?
-
- -- From the revision history: (Constrain_Index): Call
- -- Process_Range_Expr_In_Decl with range checking off for range
- -- bounds that are attributes. This avoids some horrible
- -- constraint error checks.
-
- if Nkind (R) = N_Range
- and then Nkind (Low_Bound (R)) = N_Attribute_Reference
- and then Nkind (High_Bound (R)) = N_Attribute_Reference
- then
- Checks_Off := True;
- end if;
-
- Process_Range_Expr_In_Decl (R, T, Empty_List, Checks_Off);
+ Process_Range_Expr_In_Decl (R, T, Empty_List);
if not Error_Posted (S)
and then
Is_Static : Boolean := True;
procedure Collect_Fixed_Components (Typ : Entity_Id);
- -- Collect components of parent type that do not appear in a variant
- -- part.
+ -- Collect parent type components that do not appear in a variant part
procedure Create_All_Components;
-- Iterate over Comp_List to create the components of the subtype.
-- 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);
is
Formal : Entity_Id;
New_Formal : Entity_Id;
- Same_Subt : constant Boolean :=
- Is_Scalar_Type (Parent_Type)
- and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
Visible_Subp : Entity_Id := Parent_Subp;
function Is_Private_Overriding return Boolean;
procedure Replace_Type (Id, New_Id : Entity_Id) is
Acc_Type : Entity_Id;
IR : Node_Id;
+ Par : constant Node_Id := Parent (Derived_Type);
begin
-- When the type is an anonymous access type, create a new access
Set_Etype (New_Id, Acc_Type);
Set_Scope (New_Id, New_Subp);
- -- Create a reference to it.
+ -- Create a reference to it
IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
Set_Itype (IR, Acc_Type);
Set_Etype (New_Id, Etype (Id));
end if;
end;
+
elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
or else
(Ekind (Etype (Id)) = E_Record_Type_With_Private
and then Present (Full_View (Etype (Id)))
- and then Base_Type (Full_View (Etype (Id))) =
- Base_Type (Parent_Type))
+ and then
+ Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type))
then
-
-- Constraint checks on formals are generated during expansion,
-- based on the signature of the original subprogram. The bounds
-- of the derived type are not relevant, and thus we can use
-- be used (a case statement, for example) and for those cases
-- we must use the derived type (first subtype), not its base.
- if Etype (Id) = Parent_Type
- and then Same_Subt
- then
- Set_Etype (New_Id, Derived_Type);
+ -- If the derived_type_definition has no constraints, we know that
+ -- the derived type has the same constraints as the first subtype
+ -- of the parent, and we can also use it rather than its base,
+ -- which can lead to more efficient code.
+
+ if Etype (Id) = Parent_Type then
+ if Is_Scalar_Type (Parent_Type)
+ and then
+ Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
+ then
+ Set_Etype (New_Id, Derived_Type);
+
+ elsif Nkind (Par) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
+ and then
+ Is_Entity_Name
+ (Subtype_Indication (Type_Definition (Par)))
+ then
+ Set_Etype (New_Id, Derived_Type);
+
+ else
+ Set_Etype (New_Id, Base_Type (Derived_Type));
+ end if;
+
else
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;
return;
- elsif Is_Unchecked_Union (Parent_Type) then
- Error_Msg_N ("cannot derive from Unchecked_Union type", N);
+ -- Ada 2005 (AI-231): Static check
+
+ elsif Is_Access_Type (Parent_Type)
+ and then Null_Exclusion_Present (Type_Definition (N))
+ and then Can_Never_Be_Null (Parent_Type)
+ then
+ Error_Msg_N ("(Ada 2005) null exclusion not allowed if parent is "
+ & "already non-null", Type_Definition (N));
end if;
-- Only composite types other than array types are allowed to have
-- be used for further derivation until the end of its visible part.
-- Note that derivation in the private part of the package is allowed.
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Derived_Type (Parent_Type)
and then In_Visible_Part (Scope (Parent_Type))
then
- if Ada_83 and then Comes_From_Source (Indic) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
Error_Msg_N
("(Ada 83): premature use of type for derivation", Indic);
end if;
Defining_Identifier => T,
Subtype_Indication => Relocate_Node (Obj_Def)));
- -- This subtype may need freezing and it will not be done
+ -- This subtype may need freezing, and this will not be done
-- automatically if the object declaration is not in a
-- declarative part. Since this is an object declaration, the
-- type cannot always be frozen here. Deferred constants do not
elsif Can_Derive_From (Standard_Long_Long_Float) then
Base_Typ := Standard_Long_Long_Float;
- -- If we can't derive from any existing type, use long long float
+ -- If we can't derive from any existing type, use long_long_float
-- and give appropriate message explaining the problem.
else
-- This is achieved by appending Derived_Base discriminants into
-- Discs, which has the side effect of returning a non empty Discs
-- list to the caller of Inherit_Components, which is what we want.
+ -- This must be done for private derived types if there are explicit
+ -- stored discriminants, to ensure that we can retrieve the values of
+ -- the constraints provided in the ancestors.
if Inherit_Discr
and then Is_Empty_Elmt_List (Discs)
- and then (not Is_Private_Type (Derived_Base)
- or Is_Generic_Type (Derived_Base))
+ and then Present (First_Discriminant (Derived_Base))
+ and then
+ (not Is_Private_Type (Derived_Base)
+ or else Is_Completely_Hidden
+ (First_Stored_Discriminant (Derived_Base))
+ or else Is_Generic_Type (Derived_Base))
then
D := First_Discriminant (Derived_Base);
while Present (D) loop
elsif T = Any_Character then
- if not Ada_83 then
+ if Ada_Version >= Ada_95 then
Error_Msg_N
("ambiguous character literals (could be Wide_Character)",
I);
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+ -- Ada 2005 (AI-254)
+
+ if Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ and then Protected_Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ then
+ Discr_Type :=
+ Replace_Anonymous_Access_To_Protected_Subprogram
+ (Discr, Discr_Type);
+ end if;
+
else
Find_Type (Discriminant_Type (Discr));
Discr_Type := Etype (Discriminant_Type (Discr));
if Is_Access_Type (Discr_Type) then
- -- Ada 0Y (AI-230): Access discriminant allowed in non-limited
+ -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
-- record types
- if not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Check_Access_Discriminant_Requires_Limited
(Discr, Discriminant_Type (Discr));
end if;
- if Ada_83 and then Comes_From_Source (Discr) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
Error_Msg_N
("(Ada 83) access discriminant not allowed", Discr);
end if;
("discriminant defaults not allowed for formal type",
Expression (Discr));
- elsif Is_Tagged_Type (Current_Scope) then
+ -- Tagged types cannot have defaulted discriminants, but a
+ -- non-tagged private type with defaulted discriminants
+ -- can have a tagged completion.
+
+ elsif Is_Tagged_Type (Current_Scope)
+ and then Comes_From_Source (N)
+ then
Error_Msg_N
("discriminants of tagged type cannot have defaults",
Expression (Discr));
Default_Not_Present := True;
end if;
+ -- Ada 2005 (AI-231): Set the null-excluding attribute and carry
+ -- out some static checks.
+
+ if Ada_Version >= Ada_05
+ and then (Null_Exclusion_Present (Discr)
+ or else Can_Never_Be_Null (Discr_Type))
+ then
+ Set_Can_Never_Be_Null (Defining_Identifier (Discr));
+ Null_Exclusion_Static_Checks (Discr);
+ end if;
+
Next (Discr);
end loop;
Find_Type (S);
Check_Incomplete (S);
+
+ -- Ada 2005 (AI-231): Static check
+
+ if Ada_Version >= Ada_05
+ and then Present (Parent (S))
+ and then Null_Exclusion_Present (Parent (S))
+ and then Nkind (Parent (S)) /= N_Access_To_Object_Definition
+ and then not Is_Access_Type (Entity (S))
+ then
+ Error_Msg_N
+ ("(Ada 2005) null-exclusion part requires an access type", S);
+ end if;
return Entity (S);
-- Case of constraint present, so that we have an N_Subtype_Indication
P := Parent (S);
Subtype_Mark_Id := Entity (Subtype_Mark (S));
- if Is_Unchecked_Union (Subtype_Mark_Id)
- and then Comes_From_Source (Related_Nod)
- then
- Error_Msg_N
- ("cannot create subtype of Unchecked_Union", Related_Nod);
- end if;
-
-- Explicit subtype declaration case
if Nkind (P) = N_Subtype_Declaration then
OSDN Git Service
