-- 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.
-- 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));
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;
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
-- 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
OSDN Git Service
