Check : Boolean);
-- The body for a stream subprogram may be generated outside of the scope
-- of the type. If the type is fully private, it may depend on the full
- -- view of other types (e.g. indices) that are currently private as well.
+ -- view of other types (e.g. indexes) that are currently private as well.
-- We install the declarations of the package in which the type is declared
-- before compiling the body in what is its proper environment. The Check
-- parameter indicates if checks are to be suppressed for the stream body.
-- defining it, is returned. In both cases, inheritance of representation
-- aspects is thus taken into account.
+ function Full_Base (T : Entity_Id) return Entity_Id;
+ -- The stream functions need to examine the underlying representation of
+ -- composite types. In some cases T may be non-private but its base type
+ -- is, in which case the function returns the corresponding full view.
+
function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
-- Given a type, find a corresponding stream convert pragma that applies to
-- the implementation base type of this type (Typ). If found, return the
-- eventually we plan to expand the functions that are treated as
-- build-in-place to include other composite result types.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Build_In_Place_Function_Call (Pref)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
-- and T is B for the cases of Body_Version, or Version applied to a
-- subprogram acting as its own spec, and S for Version applied to a
-- subprogram spec or package. This sequence of code references the
- -- the unsigned constant created in the main program by the binder.
+ -- unsigned constant created in the main program by the binder.
-- A special exception occurs for Standard, where the string returned
-- is a copy of the library string in gnatvsn.ads.
-- to Callable. Generate:
-- callable (Task_Id (Pref._disp_get_task_id));
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
elsif not Is_Variable (Pref)
or else Present (Formal_Ent)
- or else (Ada_Version < Ada_05
+ or else (Ada_Version < Ada_2005
and then Is_Aliased_View (Pref))
- or else (Ada_Version >= Ada_05
+ or else (Ada_Version >= Ada_2005
and then Is_Constrained_Aliased_View (Pref))
then
Res := True;
-- internally for passing to the Extra_Constrained parameter.
else
- Res := Is_Constrained (Underlying_Type (Etype (Ent)));
+ -- In Ada 2012, test for case of a limited tagged type, in
+ -- which case the attribute is always required to return
+ -- True. The underlying type is tested, to make sure we also
+ -- return True for cases where there is an unconstrained
+ -- object with an untagged limited partial view which has
+ -- defaulted discriminants (such objects always produce a
+ -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
+
+ Res := Is_Constrained (Underlying_Type (Etype (Ent)))
+ or else
+ (Ada_Version >= Ada_2012
+ and then Is_Tagged_Type (Underlying_Type (Ptyp))
+ and then Is_Limited_Type (Ptyp));
end if;
- Rewrite (N,
- New_Reference_To (Boolean_Literals (Res), Loc));
+ Rewrite (N, New_Reference_To (Boolean_Literals (Res), Loc));
end;
-- Prefix is not an entity name. These are also cases where we can
-- always tell at compile time by looking at the form and type of the
-- prefix. If an explicit dereference of an object with constrained
- -- partial view, this is unconstrained (Ada 2005 AI-363).
+ -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
+ -- underlying type is a limited tagged type, then Constrained is
+ -- required to always return True (Ada 2012: AI05-0214).
else
Rewrite (N,
not Is_Variable (Pref)
or else
(Nkind (Pref) = N_Explicit_Dereference
- and then
- not Has_Constrained_Partial_View (Base_Type (Ptyp)))
- or else Is_Constrained (Underlying_Type (Ptyp))),
+ and then
+ not Has_Constrained_Partial_View (Base_Type (Ptyp)))
+ or else Is_Constrained (Underlying_Type (Ptyp))
+ or else (Ada_Version >= Ada_2012
+ and then Is_Tagged_Type (Underlying_Type (Ptyp))
+ and then Is_Limited_Type (Ptyp))),
Loc));
end if;
Make_Pragma (Loc,
Chars => Name_Import,
Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Lang),
+ Make_Pragma_Argument_Association (Loc, Expression => Lang),
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc, Chars (Ent))),
+ Expression => Make_Identifier (Loc, Chars (Ent))),
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_String_Literal (Loc, Str))))));
+ Expression => Make_String_Literal (Loc, Str))))));
Set_Entity (N, Ent);
Rewrite (N, New_Occurrence_Of (Ent, Loc));
-- dynamically through a dispatching call, as for other task
-- attributes applied to interfaces.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
-- We cannot figure out a practical way to implement this
-- accessibility check on virtual machines, so we omit it.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Tagged_Type_Expansion
then
Insert_Action (N,
Object_Parm :=
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (New_Itype,
- New_Reference_To
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc)),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (New_Itype,
+ New_Reference_To
+ (First_Entity
+ (Protected_Body_Subprogram (Subprg)),
+ Loc)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
end;
(First_Entity
(Protected_Body_Subprogram (Subprg)),
Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
end if;
(Discriminant_Default_Value (First_Discriminant (U_Type)))
then
Build_Mutable_Record_Read_Procedure
- (Loc, Base_Type (U_Type), Decl, Pname);
+ (Loc, Full_Base (U_Type), Decl, Pname);
else
Build_Record_Read_Procedure
- (Loc, Base_Type (U_Type), Decl, Pname);
+ (Loc, Full_Base (U_Type), Decl, Pname);
end if;
-- Suppress checks, uninitialized or otherwise invalid
Rewrite_Stream_Proc_Call (Pname);
end Read;
+ ---------
+ -- Ref --
+ ---------
+
+ -- Ref is identical to To_Address, see To_Address for processing
+
---------------
-- Remainder --
---------------
-- Generate:
-- terminated (Task_Id (Pref._disp_get_task_id));
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type
and then Is_Interface (Ptyp)
and then Is_Task_Interface (Ptyp)
-- To_Address --
----------------
- -- Transforms System'To_Address (X) into unchecked conversion
- -- from (integral) type of X to type address.
+ -- Transforms System'To_Address (X) and System.Address'Ref (X) into
+ -- unchecked conversion from (integral) type of X to type address.
- when Attribute_To_Address =>
+ when Attribute_To_Address | Attribute_Ref =>
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (First (Exprs))));
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
- -- Btyp!(Pref) >= Btyp!(Ptyp'First)
- -- and then
- -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
+ -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
---------------------
-- Make_Range_Test --
end if;
return
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ge (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Btyp, Temp),
-
- Right_Opnd =>
+ Make_In (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Btyp, Temp),
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_First))),
-
- Right_Opnd =>
- Make_Op_Le (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Btyp, Temp),
-
- Right_Opnd =>
+ Attribute_Name => Name_First)),
+ High_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Ftp : Entity_Id;
begin
- -- For vax fpt types, call appropriate routine in special vax
- -- floating point unit. We do not have to worry about loads in
- -- this case, since these types have no signalling NaN's.
- if Vax_Float (Btyp) then
- Expand_Vax_Valid (N);
+ case Float_Rep (Btyp) is
- -- The AAMP back end handles Valid for floating-point types
+ -- For vax fpt types, call appropriate routine in special
+ -- vax floating point unit. No need to worry about loads in
+ -- this case, since these types have no signalling NaN's.
- elsif Is_AAMP_Float (Btyp) then
- Analyze_And_Resolve (Pref, Ptyp);
- Set_Etype (N, Standard_Boolean);
- Set_Analyzed (N);
+ when VAX_Native => Expand_Vax_Valid (N);
- -- Non VAX float case
+ -- The AAMP back end handles Valid for floating-point types
- else
- Find_Fat_Info (Ptyp, Ftp, Pkg);
-
- -- If the floating-point object might be unaligned, we need
- -- to call the special routine Unaligned_Valid, which makes
- -- the needed copy, being careful not to load the value into
- -- any floating-point register. The argument in this case is
- -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
-
- if Is_Possibly_Unaligned_Object (Pref) then
- Expand_Fpt_Attribute
- (N, Pkg, Name_Unaligned_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Pref),
- Attribute_Name => Name_Address)));
+ when AAMP =>
+ Analyze_And_Resolve (Pref, Ptyp);
+ Set_Etype (N, Standard_Boolean);
+ Set_Analyzed (N);
- -- In the normal case where we are sure the object is
- -- aligned, we generate a call to Valid, and the argument in
- -- this case is obj'Unrestricted_Access (after converting
- -- obj to the right floating-point type).
+ when IEEE_Binary =>
+ Find_Fat_Info (Ptyp, Ftp, Pkg);
- else
- Expand_Fpt_Attribute
- (N, Pkg, Name_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Ftp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
- end if;
- end if;
+ -- If the floating-point object might be unaligned, we
+ -- need to call the special routine Unaligned_Valid,
+ -- which makes the needed copy, being careful not to
+ -- load the value into any floating-point register.
+ -- The argument in this case is obj'Address (see
+ -- Unaligned_Valid routine in Fat_Gen).
+
+ if Is_Possibly_Unaligned_Object (Pref) then
+ Expand_Fpt_Attribute
+ (N, Pkg, Name_Unaligned_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Pref),
+ Attribute_Name => Name_Address)));
+
+ -- In the normal case where we are sure the object is
+ -- aligned, we generate a call to Valid, and the argument
+ -- in this case is obj'Unrestricted_Access (after
+ -- converting obj to the right floating-point type).
+
+ else
+ Expand_Fpt_Attribute
+ (N, Pkg, Name_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Ftp, Pref),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
+ end case;
-- One more task, we still need a range check. Required
-- only if we have a constraint, since the Valid routine
(Discriminant_Default_Value (First_Discriminant (U_Type)))
then
Build_Mutable_Record_Write_Procedure
- (Loc, Base_Type (U_Type), Decl, Pname);
+ (Loc, Full_Base (U_Type), Decl, Pname);
else
Build_Record_Write_Procedure
- (Loc, Base_Type (U_Type), Decl, Pname);
+ (Loc, Full_Base (U_Type), Decl, Pname);
end if;
Insert_Action (N, Decl);
-- that the result is in range.
when Attribute_Aft |
- Attribute_Max_Size_In_Storage_Elements
- =>
+ Attribute_Max_Alignment_For_Allocation |
+ Attribute_Max_Size_In_Storage_Elements =>
Apply_Universal_Integer_Attribute_Checks (N);
-- The following attributes should not appear at this stage, since they
Attribute_Stub_Type |
Attribute_Target_Name |
Attribute_Type_Class |
+ Attribute_Type_Key |
Attribute_Unconstrained_Array |
Attribute_Universal_Literal_String |
Attribute_Wchar_T_Size |
-- These checks are not generated for modular types, since the proper
-- semantics for Succ and Pred on modular types is to wrap, not raise CE.
+ -- We also suppress these checks if we are the right side of an assignment
+ -- statement or the expression of an object declaration, where the flag
+ -- Suppress_Assignment_Checks is set for the assignment/declaration.
procedure Expand_Pred_Succ (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Parent (N);
Cnam : Name_Id;
begin
Cnam := Name_Last;
end if;
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
- Attribute_Name => Cnam)),
- Reason => CE_Overflow_Check_Failed));
+ if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
+ or else not Suppress_Assignment_Checks (P)
+ then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
+ Attribute_Name => Cnam)),
+ Reason => CE_Overflow_Check_Failed));
+ end if;
end Expand_Pred_Succ;
-------------------
raise Program_Error;
end case;
- -- If neither the base type nor the root type is VAX_Float then VAX
+ -- If neither the base type nor the root type is VAX_Native then VAX
-- float is out of the picture, and we can just use the root type.
else
-- the compiler will generate in-place stream routines for string types
-- that appear in GNAT's library, but will generate calls via rtsfind
-- to library routines for user code.
+
-- ??? For now, disable this code for JVM, since this generates a
- -- VerifyError exception at run-time on e.g. c330001.
- -- This is disabled for AAMP, to avoid making dependences on files not
+ -- VerifyError exception at run time on e.g. c330001.
+
+ -- This is disabled for AAMP, to avoid creating dependences on files not
-- supported in the AAMP library (such as s-fileio.adb).
if VM_Target /= JVM_Target
end if;
end Find_Stream_Subprogram;
+ ---------------
+ -- Full_Base --
+ ---------------
+
+ function Full_Base (T : Entity_Id) return Entity_Id is
+ BT : Entity_Id;
+
+ begin
+ BT := Base_Type (T);
+
+ if Is_Private_Type (BT)
+ and then Present (Full_View (BT))
+ then
+ BT := Full_View (BT);
+ end if;
+
+ return BT;
+ end Full_Base;
+
-----------------------
-- Get_Index_Subtype --
-----------------------