Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
- if Is_Access_Protected_Subprogram_Type (Btyp) then
- Expand_Access_To_Protected_Op (N, Pref, Typ);
+ Access_Cases : declare
+ Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp);
+ Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
- -- If the prefix is a type name, this is a reference to the current
- -- instance of the type, within its initialization procedure.
-
- elsif Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- then
- declare
- Par : Node_Id;
- Formal : Entity_Id;
-
- begin
- -- If the current instance name denotes a task type, then the
- -- access attribute is rewritten to be the name of the "_task"
- -- parameter associated with the task type's task procedure.
- -- An unchecked conversion is applied to ensure a type match in
- -- cases of expander-generated calls (e.g., init procs).
-
- if Is_Task_Type (Entity (Pref)) then
- Formal :=
- First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
- while Present (Formal) loop
- exit when Chars (Formal) = Name_uTask;
- Next_Entity (Formal);
- end loop;
-
- pragma Assert (Present (Formal));
-
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- New_Occurrence_Of (Formal, Loc)));
- Set_Etype (N, Typ);
+ begin
+ if Is_Access_Protected_Subprogram_Type (Btyp) then
+ Expand_Access_To_Protected_Op (N, Pref, Typ);
- -- The expression must appear in a default expression, (which
- -- in the initialization procedure is the right-hand side of an
- -- assignment), and not in a discriminant constraint.
+ -- If prefix is a type name, this is a reference to the current
+ -- instance of the type, within its initialization procedure.
- else
- Par := Parent (N);
- while Present (Par) loop
- exit when Nkind (Par) = N_Assignment_Statement;
+ elsif Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ then
+ declare
+ Par : Node_Id;
+ Formal : Entity_Id;
- if Nkind (Par) = N_Component_Declaration then
- return;
- end if;
+ begin
+ -- If the current instance name denotes a task type, then
+ -- the access attribute is rewritten to be the name of the
+ -- "_task" parameter associated with the task type's task
+ -- procedure. An unchecked conversion is applied to ensure
+ -- a type match in cases of expander-generated calls (e.g.
+ -- init procs).
+
+ if Is_Task_Type (Entity (Pref)) then
+ Formal :=
+ First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
+ while Present (Formal) loop
+ exit when Chars (Formal) = Name_uTask;
+ Next_Entity (Formal);
+ end loop;
- Par := Parent (Par);
- end loop;
+ pragma Assert (Present (Formal));
- if Present (Par) then
Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Attribute_Name => Attribute_Name (N)));
+ Unchecked_Convert_To (Typ,
+ New_Occurrence_Of (Formal, Loc)));
+ Set_Etype (N, Typ);
- Analyze_And_Resolve (N, Typ);
- end if;
- end if;
- end;
+ -- The expression must appear in a default expression,
+ -- (which in the initialization procedure is the
+ -- right-hand side of an assignment), and not in a
+ -- discriminant constraint.
- -- The following handles cases involving interfaces and when the
- -- prefix of an access attribute is an explicit dereference. In the
- -- case where the access attribute is specifically Attribute_Access,
- -- we only do this when the context type is E_General_Access_Type,
- -- and not for anonymous access types. It seems that this code should
- -- be used for anonymous contexts as well, but that causes various
- -- regressions, such as on prefix-notation calls to dispatching
- -- operations and back-end errors on access type conversions. ???
-
- elsif Id /= Attribute_Access
- or else Ekind (Btyp) = E_General_Access_Type
- then
- declare
- Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
- Parm_Ent : Entity_Id;
- Conversion : Node_Id;
+ else
+ Par := Parent (N);
+ while Present (Par) loop
+ exit when Nkind (Par) = N_Assignment_Statement;
- begin
- -- If the prefix of an Access attribute is a dereference of an
- -- access parameter (or a renaming of such a dereference) and
- -- the context is a general access type (but not an anonymous
- -- access type), then rewrite the attribute as a conversion of
- -- the access parameter to the context access type. This will
- -- result in an accessibility check being performed, if needed.
-
- -- (X.all'Access => Acc_Type (X))
-
- -- Note: Limit the expansion of an attribute applied to a
- -- dereference of an access parameter so that it's only done
- -- for 'Access. This fixes a problem with 'Unrestricted_Access
- -- that leads to errors in the case where the attribute type
- -- is access-to-variable and the access parameter is
- -- access-to-constant. The conversion is only done to get
- -- accessibility checks, so it makes sense to limit it to
- -- 'Access (and consistent with existing comment).
-
- if Nkind (Ref_Object) = N_Explicit_Dereference
- and then Is_Entity_Name (Prefix (Ref_Object))
- and then Id = Attribute_Access
- then
- Parm_Ent := Entity (Prefix (Ref_Object));
+ if Nkind (Par) = N_Component_Declaration then
+ return;
+ end if;
- if Ekind (Parm_Ent) in Formal_Kind
- and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
- and then Present (Extra_Accessibility (Parm_Ent))
- then
- Conversion :=
- Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
+ Par := Parent (Par);
+ end loop;
- Rewrite (N, Conversion);
- Analyze_And_Resolve (N, Typ);
+ if Present (Par) then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Attribute_Name => Attribute_Name (N)));
- return;
+ Analyze_And_Resolve (N, Typ);
+ end if;
end if;
- end if;
+ end;
- -- Ada 2005 (AI-251): If the designated type is an interface,
- -- then rewrite the referenced object as a conversion, to force
- -- the displacement of the pointer to the secondary dispatch
- -- table.
+ -- If the prefix of an Access attribute is a dereference of an
+ -- access parameter (or a renaming of such a dereference) and
+ -- the context is a general access type (but not an anonymous
+ -- access type), then rewrite the attribute as a conversion of
+ -- the access parameter to the context access type. This will
+ -- result in an accessibility check being performed, if needed.
+
+ -- (X.all'Access => Acc_Type (X))
+
+ -- Note: Limit the expansion of an attribute applied to a
+ -- dereference of an access parameter so that it's only done
+ -- for 'Access. This fixes a problem with 'Unrestricted_Access
+ -- that leads to errors in the case where the attribute type
+ -- is access-to-variable and the access parameter is
+ -- access-to-constant. The conversion is only done to get
+ -- accessibility checks, so it makes sense to limit it to
+ -- 'Access.
+
+ elsif Nkind (Ref_Object) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Ref_Object))
+ and then Ekind (Btyp) = E_General_Access_Type
+ and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind
+ and then Ekind (Etype (Entity (Prefix (Ref_Object))))
+ = E_Anonymous_Access_Type
+ and then Present (Extra_Accessibility
+ (Entity (Prefix (Ref_Object))))
+ then
+ Rewrite (N,
+ Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
+ Analyze_And_Resolve (N, Typ);
- if Is_Interface (Directly_Designated_Type (Btyp)) then
+ -- Ada 2005 (AI-251): If the designated type is an interface we
+ -- add an implicit conversion to force the displacement of the
+ -- pointer to reference the secondary dispatch table.
- -- When the object is an explicit dereference, just convert
- -- the dereference's prefix.
+ elsif Is_Interface (Btyp_DDT)
+ and then (Comes_From_Source (N)
+ or else Comes_From_Source (Ref_Object)
+ or else (Nkind (Ref_Object) in N_Has_Chars
+ and then Chars (Ref_Object) = Name_uInit))
+ then
+ if Nkind (Ref_Object) /= N_Explicit_Dereference then
- if Nkind (Ref_Object) = N_Explicit_Dereference then
- Conversion :=
- Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
+ -- No implicit conversion required if types match
- -- It seems rather bizarre that we generate a conversion of
- -- a tagged object to an access type, since such conversions
- -- are not normally permitted, but Expand_N_Type_Conversion
- -- (actually Expand_Interface_Conversion) is designed to
- -- handle them in the interface case. Do we really want to
- -- create such odd conversions???
+ if Btyp_DDT /= Etype (Ref_Object) then
+ Rewrite (Prefix (N),
+ Convert_To (Directly_Designated_Type (Typ),
+ New_Copy_Tree (Prefix (N))));
- else
- Conversion :=
- Convert_To (Typ, New_Copy_Tree (Ref_Object));
+ Analyze_And_Resolve (Prefix (N),
+ Directly_Designated_Type (Typ));
end if;
- Rewrite (N, Conversion);
- Analyze_And_Resolve (N, Typ);
+ -- When the object is an explicit dereference, convert the
+ -- dereference's prefix.
+
+ else
+ declare
+ Obj_DDT : constant Entity_Id :=
+ Base_Type
+ (Directly_Designated_Type
+ (Etype (Prefix (Ref_Object))));
+ begin
+ -- No implicit conversion required if designated types
+ -- match.
+
+ if Obj_DDT /= Btyp_DDT
+ and then not (Is_Class_Wide_Type (Obj_DDT)
+ and then Etype (Obj_DDT) = Btyp_DDT)
+ then
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Copy_Tree (Prefix (Ref_Object))));
+ Analyze_And_Resolve (N, Typ);
+ end if;
+ end;
end if;
- end;
- end if;
+ end if;
+ end Access_Cases;
--------------
-- Adjacent --
projects / thirdparty / gcc.git / commitdiff
