Aspect_Effective_Writes, -- GNAT
Aspect_Exclusive_Functions,
Aspect_Export,
+ Aspect_Extended_Access, -- GNAT
Aspect_Extensions_Visible, -- GNAT
Aspect_Favor_Top_Level, -- GNAT
Aspect_First_Controlling_Parameter, -- GNAT
Aspect_Effective_Reads => True,
Aspect_Effective_Writes => True,
Aspect_Exceptional_Cases => True,
+ Aspect_Extended_Access => True,
Aspect_Extensions_Visible => True,
Aspect_External_Initialization => True,
Aspect_Favor_Top_Level => True,
Aspect_Dynamic_Predicate => False,
Aspect_Exceptional_Cases => False,
Aspect_Exclusive_Functions => False,
+ Aspect_Extended_Access => True,
Aspect_External_Initialization => False,
Aspect_External_Name => False,
Aspect_External_Tag => False,
Aspect_Exceptional_Cases => Name_Exceptional_Cases,
Aspect_Exclusive_Functions => Name_Exclusive_Functions,
Aspect_Export => Name_Export,
+ Aspect_Extended_Access => Name_Extended_Access,
Aspect_Extensions_Visible => Name_Extensions_Visible,
Aspect_External_Initialization => Name_External_Initialization,
Aspect_External_Name => Name_External_Name,
Aspect_Atomic_Components => Rep_Aspect,
Aspect_Bit_Order => Rep_Aspect,
Aspect_Component_Size => Rep_Aspect,
+ Aspect_Extended_Access => Rep_Aspect,
Aspect_Full_Access_Only => Rep_Aspect,
Aspect_Machine_Radix => Rep_Aspect,
Aspect_Object_Size => Rep_Aspect,
| Pragma_Export_Procedure
| Pragma_Export_Valued_Procedure
| Pragma_Extend_System
+ | Pragma_Extended_Access
| Pragma_Extensions_Visible
| Pragma_External
| Pragma_External_Name_Casing
then
null;
+ -- Nominal subtype static matching requirement does not apply
+ -- for an extended access type.
+
+ elsif Is_Extended_Access_Type (Typ) then
+ null;
+
else
Error_Msg_F
("object subtype must statically match "
and then not (Nkind (P) = N_Selected_Component
and then
Is_Overloadable (Entity (Selector_Name (P))))
- and then not Is_Aliased_View (Original_Node (P))
+ and then not Is_Aliased_View
+ (Original_Node (P),
+ For_Extended => Is_Extended_Access_Type (Btyp))
and then not In_Instance
and then not In_Inlined_Body
and then Comes_From_Source (N)
("non null exclusion of actual and formal & do not match",
Actual, Gen_T);
end if;
+
+ -- formal/actual extended access match required (regardless of
+ -- whether a formal extended access type is currently possible)
+
+ if Is_Extended_Access_Type (Act_T)
+ /= Is_Extended_Access_Type (A_Gen_T)
+ then
+ Error_Msg_N
+ ("actual type must" &
+ String'(if Is_Extended_Access_Type (A_Gen_T)
+ then ""
+ else " not") &
+ " be extended access type", Actual);
+
+ Abandon_Instantiation (Actual);
+ end if;
end Validate_Access_Type_Instance;
----------------------------------
with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Ttypes;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Uname; use Uname;
with Urealp; use Urealp;
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
end if;
+ ---------------------
+ -- Extended_Access --
+ ---------------------
+
+ -- pragma Extended_Access (first_subtype_LOCAL_NAME);
+
+ when Pragma_Extended_Access => Extended_Access : declare
+ Assoc : constant Node_Id := Arg1;
+ Typ : Entity_Id;
+ Type_Id : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Type_Id := Get_Pragma_Arg (Assoc);
+
+ if not Is_Entity_Name (Type_Id)
+ or else not Is_Type (Entity (Type_Id))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be type or subtype", Arg1);
+ end if;
+
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Typ);
+
+ if Ekind (Typ) = E_Access_Subtype then
+ Error_Pragma
+ ("pragma% not specifiable for subtype");
+ elsif Ekind (Typ) /= E_General_Access_Type then
+ Error_Pragma
+ ("pragma% only specifiable for general access type");
+ elsif Is_Derived_Type (Typ) then
+ Error_Pragma
+ ("pragma% not specifiable for derived type");
+ else
+ declare
+ Designated : constant Entity_Id := Designated_Type (Typ);
+ begin
+ if not (Is_Array_Type (Designated))
+ or else Is_Constrained (Designated)
+ then
+ Error_Pragma
+ ("pragma% only specifiable for access type" &
+ " having unconstrained array designated subtype");
+ end if;
+ end;
+ end if;
+
+ Check_First_Subtype (Arg1);
+ Check_Duplicate_Pragma (Typ);
+
+ if Rep_Item_Too_Late (Typ, N) then
+ return;
+ end if;
+ end Extended_Access;
+
------------------------
-- Extensions_Allowed --
------------------------
Pragma_Export_Procedure => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
+ Pragma_Extended_Access => 0,
Pragma_Extensions_Allowed => 0,
Pragma_Extensions_Visible => 0,
Pragma_External => -1,
Pragma_Elaborate_Body => True,
Pragma_Exceptional_Cases => True,
Pragma_Export => True,
+ Pragma_Extended_Access => True,
Pragma_Extensions_Visible => True,
Pragma_Favor_Top_Level => True,
Pragma_First_Controlling_Parameter => True,
return False;
end if;
+ declare
+ Extended_Opnd : constant Boolean :=
+ Is_Extended_Access_Type (Opnd_Type);
+ Extended_Target : constant Boolean :=
+ Is_Extended_Access_Type (Target_Type);
+ begin
+ -- An extended access value may designate objects that are
+ -- impossible to reference using a non-extended type, so
+ -- prohibit conversions that would require being able to
+ -- do the impossible.
+
+ if Extended_Opnd then
+ if not Extended_Target then
+ Conversion_Error_N
+ ("cannot convert extended access value"
+ & " to non-extended access type",
+ Operand);
+ return False;
+ end if;
+
+ -- Detect bad conversion on copy back for a view conversion
+
+ elsif Extended_Target and then Is_View_Conversion (N) then
+ Conversion_Error_N
+ ("cannot convert non-extended value"
+ & " to extended access type in view conversion",
+ Operand);
+ return False;
+ end if;
+ end;
+
-- Check the static accessibility rule of 4.6(17). Note that the
-- check is not enforced when within an instance body, since the RM
-- requires such cases to be caught at run time.
then
Conversion_Error_N
("operand has deeper level than target", Operand);
+ return False;
end if;
-- Implicit conversions aren't allowed for objects of an
and then not Is_Record_Aggregate;
end Is_Container_Aggregate;
+ -----------------------------
+ -- Is_Extended_Access_Type --
+ -----------------------------
+
+ function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Available_View (Base_Type (Ent));
+ begin
+ if Has_Aspect (Btype, Aspect_Extended_Access) then
+ declare
+ Aspect_Expr : constant Node_Id :=
+ Expression (Find_Aspect (Btype, Aspect_Extended_Access));
+ begin
+ return No (Aspect_Expr) or else Expr_Value (Aspect_Expr) /= 0;
+ end;
+ elsif Is_Derived_Type (Btype) then
+ return Is_Extended_Access_Type (Etype (Btype));
+ else
+ return False;
+ end if;
+ end Is_Extended_Access_Type;
+
---------------------------------
-- Side_Effect_Free_Statements --
---------------------------------
-- Is_Aliased_View --
---------------------
- function Is_Aliased_View (Obj : Node_Id) return Boolean is
+ function Is_Aliased_View
+ (Obj : Node_Id; For_Extended : Boolean := False) return Boolean
+ is
E : Entity_Id;
+ -- Ensure that For_Extended parameter is propagated in recursive
+ -- calls by hiding the version that has the wrong default.
+
+ function Is_Aliased_View
+ (Obj : Node_Id; For_SF : Boolean := For_Extended) return Boolean
+ renames Sem_Util.Is_Aliased_View;
+
begin
if Is_Entity_Name (Obj) then
E := Entity (Obj);
-- rewritten constructs that introduce artificial dereferences.
elsif Nkind (Obj) = N_Explicit_Dereference then
+ -- If For_Extended is False then a dereference of an extended access
+ -- value is, by definition, not aliased.
+ -- This is to prevent covert illegal type conversion via either
+ -- Not_Extended_Type'(Extended_Ptr.all'Access)
+ -- or by passing Extended_Ptr.all as an actual parameter
+ -- corresponding to an explicitly aliased formal parameter
+ -- (which would allow the callee to evaluate Aliased_Param'Access).
+
+ if Is_Extended_Access_Type (Etype (Prefix (Obj)))
+ and then not For_Extended
+ then
+ return False;
+ end if;
+
return not Is_Captured_Function_Call (Obj)
and then not
(Nkind (Parent (Obj)) = N_Object_Renaming_Declaration
and then Is_Return_Object (Defining_Entity (Parent (Obj))));
+ elsif Nkind (Obj) = N_Slice then
+ -- A slice of a bit-packed array is not considered aliased even
+ -- for an extended access type because even extended access types
+ -- don't support bit pointers.
+
+ return For_Extended
+ and then Is_Aliased_View (Prefix (Obj))
+ and then not Is_Bit_Packed_Array (Etype (Obj));
+
else
return False;
end if;
Expression (Item_2));
end;
- -- A confirming aspect for Implicit_Derenfence on a derived type
+ -- A confirming aspect for Implicit_Dereference on a derived type
-- has already been checked in Analyze_Aspect_Implicit_Dereference,
-- including the presence of renamed discriminants.
function Is_Container_Aggregate (Exp : Node_Id) return Boolean;
-- Is the given expression a container aggregate?
+ function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Returns True if Ent is a type (or a subtype thereof)
+ -- for which the Extended_Access aspect has been specified, either
+ -- explicitly or by inheritance.
+
function Is_Function_With_Side_Effects (Subp : Entity_Id) return Boolean;
-- Return True if Subp is a function with side effects, ie. it has a
-- (direct or inherited) pragma Side_Effects with static value True.
function Is_Actual_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter in a subprogram or entry call
- function Is_Aliased_View (Obj : Node_Id) return Boolean;
+ function Is_Aliased_View
+ (Obj : Node_Id; For_Extended : Boolean := False) return Boolean;
-- Determine if Obj is an aliased view, i.e. the name of an object to which
-- 'Access or 'Unchecked_Access can apply. Note that this routine uses the
-- rules of the language, it does not take into account the restriction
-- and Obj violates the restriction. The caller is responsible for calling
-- Restrict.Check_No_Implicit_Aliasing if True is returned, but there is a
-- requirement for obeying the restriction in the call context.
+ -- If For_Extended is True, then slightly different rules apply (as per
+ -- the definition of the Extended_Access aspect); for example, a slice
+ -- of an aliased array is considered to be aliased.
function Is_Ancestor_Package
(E1 : Entity_Id;
Name_Export_Object : constant Name_Id := N + $; -- GNAT
Name_Export_Procedure : constant Name_Id := N + $; -- GNAT
Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT
+ Name_Extended_Access : constant Name_Id := N + $; -- GNAT
Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT
Name_External : constant Name_Id := N + $; -- GNAT
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
Pragma_Export_Object,
Pragma_Export_Procedure,
Pragma_Export_Valued_Procedure,
+ Pragma_Extended_Access,
Pragma_Extensions_Visible,
Pragma_External,
Pragma_Finalize_Storage_Only,
projects / thirdparty / gcc.git / commitdiff
