-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Expander; use Expander;
with Freeze; use Freeze;
with Gnatvsn; use Gnatvsn;
with Itypes; use Itypes;
Stmts := No_List;
- -- Validate componants
+ -- Validate components
Validate_Component_List
(Obj_Id => Obj_Id,
Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
- Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ);
- Rec_Def : constant Node_Id := Type_Definition (Rec_Decl);
+ Comps : Node_Id;
Stmts : List_Id;
+ Typ : Entity_Id;
+ Typ_Decl : Node_Id;
+ Typ_Def : Node_Id;
+ Typ_Ext : Node_Id;
-- Start of processing for Build_Record_VS_Func
begin
+ Typ := Rec_Typ;
+
+ -- Use the root type when dealing with a class-wide type
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ_Decl := Declaration_Node (Typ);
+ Typ_Def := Type_Definition (Typ_Decl);
+
+ -- The components of a derived type are located in the extension part
+
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Ext := Record_Extension_Part (Typ_Def);
+
+ if Present (Typ_Ext) then
+ Comps := Component_List (Typ_Ext);
+ else
+ Comps := Empty;
+ end if;
+
+ -- Otherwise the components are available in the definition
+
+ else
+ Comps := Component_List (Typ_Def);
+ end if;
+
-- The code generated by this routine is as follows:
--
-- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
if not Is_Unchecked_Union (Rec_Typ) then
Validate_Fields
(Obj_Id => Obj_Id,
- Fields => Discriminant_Specifications (Rec_Decl),
+ Fields => Discriminant_Specifications (Typ_Decl),
Stmts => Stmts);
end if;
Validate_Component_List
(Obj_Id => Obj_Id,
- Comp_List => Component_List (Rec_Def),
+ Comp_List => Comps,
Stmts => Stmts);
-- Generate:
Selector_Name => Make_Identifier (Loc, Nam));
-- The generated call is given the provided set of parameters, and then
- -- wrapped in a conversion which converts the result to the target type
- -- We use the base type as the target because a range check may be
- -- required.
+ -- wrapped in a conversion which converts the result to the target type.
Rewrite (N,
- Unchecked_Convert_To (Base_Type (Etype (N)),
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name => Fnm,
Parameter_Associations => Args)));
Stmts : List_Id;
begin
+ Func_Id := Make_Temporary (Loc, 'F');
+
-- Wrap the condition of the while loop in a Boolean function.
-- This avoids the duplication of the same code which may lead
-- to gigi issues with respect to multiple declaration of the
-- same entity in the presence of side effects or checks. Note
- -- that the condition actions must also be relocated to the
- -- wrapping function.
+ -- that the condition actions must also be relocated into the
+ -- wrapping function because they may contain itypes, e.g. in
+ -- the case of a comparison involving slices.
-- Generate:
-- <condition actions>
Append_To (Stmts,
Make_Simple_Return_Statement (Loc,
- Expression => Relocate_Node (Condition (Scheme))));
+ Expression =>
+ New_Copy_Tree (Condition (Scheme),
+ New_Scope => Func_Id)));
-- Generate:
-- function Fnn return Boolean is
-- <Stmts>
-- end Fnn;
- Func_Id := Make_Temporary (Loc, 'F');
Func_Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Insert_Action (Loop_Stmt, Func_Decl);
Pop_Scope;
+ -- The analysis of the condition may have generated entities
+ -- (such as itypes) that are now used within the function.
+ -- Adjust their scopes accordingly so that their use appears
+ -- in their scope of definition.
+
+ declare
+ Ent : Entity_Id;
+
+ begin
+ Ent := First_Entity (Loop_Id);
+
+ while Present (Ent) loop
+ -- Various entities that now occur within the function
+ -- need to have their scope reset, but not all entities
+ -- associated with Loop_Id are now inside the function.
+ -- The function entity itself and loop parameters can
+ -- be outside the function, and there may be others.
+ -- It's not clear how the determination of what entity
+ -- scopes need to be adjusted can be made accurately.
+ -- Perhaps it will be necessary to traverse the function
+ -- body to find the exact entities whose scopes need to
+ -- be reset to the function's Entity_Id. ???
+
+ if Ekind (Ent) /= E_Loop_Parameter
+ and then Ent /= Func_Id
+ then
+ Set_Scope (Ent, Func_Id);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end;
+
-- Transform the original while loop into an infinite loop
-- where the last statement checks the negated condition. This
-- placement ensures that the condition will not be evaluated
-- generate conditionals in the code, so check the relevant restriction.
Check_Restriction (No_Implicit_Conditionals, N);
-
- -- In Modify_Tree_For_C mode, we rewrite as an if expression
-
- if Modify_Tree_For_C then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Expr : constant Node_Id := First (Expressions (N));
- Left : constant Node_Id := Relocate_Node (Expr);
- Right : constant Node_Id := Relocate_Node (Next (Expr));
-
- function Make_Compare (Left, Right : Node_Id) return Node_Id;
- -- Returns Left >= Right for Max, Left <= Right for Min
-
- ------------------
- -- Make_Compare --
- ------------------
-
- function Make_Compare (Left, Right : Node_Id) return Node_Id is
- begin
- if Attribute_Name (N) = Name_Max then
- return
- Make_Op_Ge (Loc,
- Left_Opnd => Left,
- Right_Opnd => Right);
- else
- return
- Make_Op_Le (Loc,
- Left_Opnd => Left,
- Right_Opnd => Right);
- end if;
- end Make_Compare;
-
- -- Start of processing for Min_Max
-
- begin
- -- If both Left and Right are side effect free, then we can just
- -- use Duplicate_Expr to duplicate the references and return
-
- -- (if Left >=|<= Right then Left else Right)
-
- if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
- Rewrite (N,
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Compare (Left, Right),
- Duplicate_Subexpr_No_Checks (Left),
- Duplicate_Subexpr_No_Checks (Right))));
-
- -- Otherwise we generate declarations to capture the values.
-
- -- The translation is
-
- -- do
- -- T1 : constant typ := Left;
- -- T2 : constant typ := Right;
- -- in
- -- (if T1 >=|<= T2 then T1 else T2)
- -- end;
-
- else
- declare
- T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
- T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
-
- begin
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => T1,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etype (Left), Loc),
- Expression => Relocate_Node (Left)),
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => T2,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etype (Right), Loc),
- Expression => Relocate_Node (Right))),
-
- Expression =>
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Compare
- (New_Occurrence_Of (T1, Loc),
- New_Occurrence_Of (T2, Loc)),
- New_Occurrence_Of (T1, Loc),
- New_Occurrence_Of (T2, Loc)))));
- end;
- end if;
-
- Analyze_And_Resolve (N, Typ);
- end;
- end if;
end Expand_Min_Max_Attribute;
----------------------------------
when Attribute_Address => Address : declare
Task_Proc : Entity_Id;
+ function Is_Unnested_Component_Init (N : Node_Id) return Boolean;
+ -- Returns True if N is being used to initialize a component of
+ -- an activation record object where the component corresponds to
+ -- the object denoted by the prefix of the attribute N.
+
+ function Is_Unnested_Component_Init (N : Node_Id) return Boolean is
+ begin
+ return Present (Parent (N))
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then Is_Entity_Name (Pref)
+ and then Present (Activation_Record_Component (Entity (Pref)))
+ and then Nkind (Name (Parent (N))) = N_Selected_Component
+ and then Entity (Selector_Name (Name (Parent (N)))) =
+ Activation_Record_Component (Entity (Pref));
+ end Is_Unnested_Component_Init;
+
+ -- Start of processing for Address
+
begin
-- If the prefix is a task or a task type, the useful address is that
-- of the procedure for the task body, i.e. the actual program unit.
-- "displaced" to reference the tag associated with the interface
-- type. In order to obtain the real address of such objects we
-- generate a call to a run-time subprogram that returns the base
- -- address of the object.
-
- -- This processing is not needed in the VM case, where dispatching
- -- issues are taken care of by the virtual machine.
+ -- address of the object. This call is not generated in cases where
+ -- the attribute is being used to initialize a component of an
+ -- activation record object where the component corresponds to
+ -- prefix of the attribute (for back ends that require "unnesting"
+ -- of nested subprograms), since the address needs to be assigned
+ -- as-is to such components.
elsif Is_Class_Wide_Type (Ptyp)
and then Is_Interface (Underlying_Type (Ptyp))
and then Tagged_Type_Expansion
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
+ and then not Is_Unnested_Component_Init (N)
then
Rewrite (N,
Make_Function_Call (Loc,
New_Node := Build_Get_Alignment (Loc, New_Node);
+ -- Case where the context is an unchecked conversion to a specific
+ -- integer type. We directly convert from the alignment's type.
+
+ if Nkind (Parent (N)) = N_Unchecked_Type_Conversion then
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N);
+ return;
+
-- Case where the context is a specific integer type with which
- -- the original attribute was compatible. The function has a
- -- specific type as well, so to preserve the compatibility we
- -- must convert explicitly.
+ -- the original attribute was compatible. But the alignment has a
+ -- specific type in a-tags.ads (Standard.Natural) so, in order to
+ -- preserve type compatibility, we must convert explicitly.
- if Typ /= Standard_Integer then
+ elsif Typ /= Standard_Natural then
New_Node := Convert_To (Typ, New_Node);
end if;
when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
- function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
- -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
- -- view of an aliased object whose subtype is constrained.
-
- ---------------------------------
- -- Is_Constrained_Aliased_View --
- ---------------------------------
-
- function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
- E : Entity_Id;
-
- begin
- if Is_Entity_Name (Obj) then
- E := Entity (Obj);
-
- if Present (Renamed_Object (E)) then
- return Is_Constrained_Aliased_View (Renamed_Object (E));
- else
- return Is_Aliased (E) and then Is_Constrained (Etype (E));
- end if;
-
- else
- return Is_Aliased_View (Obj)
- and then
- (Is_Constrained (Etype (Obj))
- or else
- (Nkind (Obj) = N_Explicit_Dereference
- and then
- not Object_Type_Has_Constrained_Partial_View
- (Typ => Base_Type (Etype (Obj)),
- Scop => Current_Scope)));
- end if;
- end Is_Constrained_Aliased_View;
-
-- Start of processing for Constrained
begin
-- If the prefix is an access to object, the attribute applies to
-- the designated object, so rewrite with an explicit dereference.
- elsif Is_Access_Type (Etype (Pref))
+ elsif Is_Access_Type (Ptyp)
and then
(not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
then
New_Occurrence_Of
(Extra_Constrained (Entity (Pref)), Sloc (N)));
- -- For all other entity names, we can tell at compile time
-
- elsif Is_Entity_Name (Pref) then
- declare
- Ent : constant Entity_Id := Entity (Pref);
- Res : Boolean;
-
- begin
- -- (RM J.4) obsolescent cases
-
- if Is_Type (Ent) then
-
- -- Private type
-
- if Is_Private_Type (Ent) then
- Res := not Has_Discriminants (Ent)
- or else Is_Constrained (Ent);
-
- -- It not a private type, must be a generic actual type
- -- that corresponded to a private type. We know that this
- -- correspondence holds, since otherwise the reference
- -- within the generic template would have been illegal.
-
- else
- if Is_Composite_Type (Underlying_Type (Ent)) then
- Res := Is_Constrained (Ent);
- else
- Res := True;
- end if;
- end if;
-
- else
- -- For access type, apply access check as needed
+ -- For all other cases, we can tell at compile time
- if Is_Access_Type (Ptyp) then
- Apply_Access_Check (N);
- end if;
-
- -- If the prefix is not a variable or is aliased, then
- -- definitely true; if it's a formal parameter without an
- -- associated extra formal, then treat it as constrained.
-
- -- Ada 2005 (AI-363): An aliased prefix must be known to be
- -- constrained in order to set the attribute to True.
-
- if not Is_Variable (Pref)
- or else Present (Formal_Ent)
- or else (Ada_Version < Ada_2005
- and then Is_Aliased_View (Pref))
- or else (Ada_Version >= Ada_2005
- and then Is_Constrained_Aliased_View (Pref))
- then
- Res := True;
-
- -- Variable case, look at type to see if it is constrained.
- -- Note that the one case where this is not accurate (the
- -- procedure formal case), has been handled above.
-
- -- We use the Underlying_Type here (and below) in case the
- -- type is private without discriminants, but the full type
- -- has discriminants. This case is illegal, but we generate
- -- it internally for passing to the Extra_Constrained
- -- parameter.
-
- else
- -- 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;
- end if;
-
- Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
- end;
+ else
+ -- For access type, apply access check as needed
- -- 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: AI95-0363). If the
- -- underlying type is a limited tagged type, then Constrained is
- -- required to always return True (Ada 2012: AI05-0214).
+ if Is_Entity_Name (Pref)
+ and then not Is_Type (Entity (Pref))
+ and then Is_Access_Type (Ptyp)
+ then
+ Apply_Access_Check (N);
+ end if;
- else
Rewrite (N,
- New_Occurrence_Of (
- Boolean_Literals (
- not Is_Variable (Pref)
- or else
- (Nkind (Pref) = N_Explicit_Dereference
- and then
- not Object_Type_Has_Constrained_Partial_View
- (Typ => Base_Type (Ptyp),
- Scop => Current_Scope))
- 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));
+ New_Occurrence_Of
+ (Boolean_Literals
+ (Exp_Util.Attribute_Constrained_Static_Value
+ (Pref)), Sloc (N)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
-- Protected case
if Is_Protected_Type (Conctyp) then
+
+ -- No need to transform 'Count into a function call if the current
+ -- scope has been eliminated. In this case such transformation is
+ -- also not viable because the enclosing protected object is not
+ -- available.
+
+ if Is_Eliminated (Current_Scope) then
+ return;
+ end if;
+
case Corresponding_Runtime_Package (Conctyp) is
when System_Tasking_Protected_Objects_Entries =>
Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
when Attribute_Enum_Rep => Enum_Rep : declare
Expr : Node_Id;
+ Ityp : Entity_Id;
+ Psiz : Uint;
begin
-- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
-- make sure that the analyzer does not complain about what otherwise
-- might be an illegal conversion.
+ -- However the target type is universal integer in most cases, which
+ -- is a very large type, so in the case of an enumeration type, we
+ -- first convert to a small signed integer type in order not to lose
+ -- the size information.
+
+ elsif Is_Enumeration_Type (Ptyp) then
+ Psiz := RM_Size (Base_Type (Ptyp));
+
+ if Psiz < 8 then
+ Ityp := Standard_Integer_8;
+
+ elsif Psiz < 16 then
+ Ityp := Standard_Integer_16;
+
+ elsif Psiz < 32 then
+ Ityp := Standard_Integer_32;
+
+ else
+ Ityp := Standard_Integer_64;
+ end if;
+
+ Rewrite (N, OK_Convert_To (Ityp, Expr));
+ Convert_To_And_Rewrite (Typ, N);
+
else
- Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
+ Rewrite (N, OK_Convert_To (Typ, Expr));
end if;
- Set_Etype (N, Typ);
Analyze_And_Resolve (N, Typ);
end Enum_Rep;
Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
+ -- Ensure that the expression is not truncated since the "bad" bits
+ -- are desired.
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Set_No_Truncation (Expr);
+ end if;
+
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
function Calculate_Header_Size return Node_Id is
begin
-- Generate:
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment))
+ -- Typ (Header_Size_With_Padding (Pref'Alignment))
return
- Convert_To (Universal_Integer,
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
-- Size : Integer := 0;
--
-- if Needs_Finalization (Pref'Tag) then
- -- Size :=
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment));
+ -- Size := Integer (Header_Size_With_Padding (Pref'Alignment));
-- end if;
--
-- and the attribute reference is replaced with a reference to Size.
-- Generate:
-- if Needs_Finalization (Pref'Tag) then
-- Size :=
- -- Universal_Integer
- -- (Header_Size_With_Padding (Pref'Alignment));
+ -- Integer (Header_Size_With_Padding (Pref'Alignment));
-- end if;
Make_If_Statement (Loc,
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Size, Loc),
- Expression => Calculate_Header_Size)))));
+ Expression =>
+ Convert_To
+ (Standard_Integer, Calculate_Header_Size))))));
Rewrite (N, New_Occurrence_Of (Size, Loc));
-- We transform
-- fixtype'Fixed_Value (integer-value)
- -- inttype'Fixed_Value (fixed-value)
+ -- inttype'Integer_Value (fixed-value)
-- into
-- respectively.
- -- We do all the required analysis of the conversion here, because we do
- -- not want this to go through the fixed-point conversion circuits. Note
- -- that the back end always treats fixed-point as equivalent to the
- -- corresponding integer type anyway.
+ -- We set Conversion_OK on the conversion because we do not want it
+ -- to go through the fixed-point conversion circuits.
when Attribute_Fixed_Value
| Attribute_Integer_Value
=>
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
- Expression => Relocate_Node (First (Exprs))));
- Set_Etype (N, Entity (Pref));
- Set_Analyzed (N);
+ Rewrite (N, OK_Convert_To (Entity (Pref), First (Exprs)));
- -- Note: it might appear that a properly analyzed unchecked
+ -- Note that it might appear that a properly analyzed unchecked
-- conversion would be just fine here, but that's not the case,
- -- since the full range checks performed by the following call
+ -- since the full range checks performed by the following calls
-- are critical.
Apply_Type_Conversion_Checks (N);
+ -- Note that Apply_Type_Conversion_Checks only deals with the
+ -- overflow checks on conversions involving fixed-point types
+ -- so we must apply range checks manually on them and expand.
+
+ Apply_Scalar_Range_Check
+ (Expression (N), Etype (N), Fixed_Int => True);
+
+ Set_Analyzed (N);
+ Expand (N);
+
-----------
-- Floor --
-----------
-- Result_Type (System.Fore (Universal_Real (Type'First)),
-- Universal_Real (Type'Last))
- -- Note that we know that the type is a non-static subtype, or Fore
- -- would have itself been computed dynamically in Eval_Attribute.
+ -- Note that we know that the type is a nonstatic subtype, or Fore would
+ -- have itself been computed dynamically in Eval_Attribute.
when Attribute_Fore =>
Rewrite (N,
--------------
when Attribute_From_Any => From_Any : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
- Build_From_Any_Call (P_Type,
+ Build_From_Any_Call (Ptyp,
Relocate_Node (First (Exprs)),
Decls));
Insert_Actions (N, Decls);
- Analyze_And_Resolve (N, P_Type);
+ Analyze_And_Resolve (N, Ptyp);
end From_Any;
----------------------
declare
Rtyp : constant Entity_Id := Root_Type (P_Type);
- Expr : Node_Id;
+
+ Expr : Node_Id; -- call to Descendant_Tag
+ Get_Tag : Node_Id; -- expression to read the 'Tag
begin
-- Read the internal tag (RM 13.13.2(34)) and use it to
- -- initialize a dummy tag value. We used to generate:
+ -- initialize a dummy tag value. We used to unconditionally
+ -- generate:
--
-- Descendant_Tag (String'Input (Strm), P_Type);
--
-- String_Input_Blk_IO, except that if the String is
-- absurdly long, it raises an exception.
--
+ -- However, if the No_Stream_Optimizations restriction
+ -- is active, we disable this unnecessary attempt at
+ -- robustness; we really need to read the string
+ -- character-by-character.
+ --
-- This value is used only to provide a controlling
-- argument for the eventual _Input call. Descendant_Tag is
-- called rather than Internal_Tag to ensure that we have a
-- this constant in Cntrl, but this caused a secondary stack
-- leak.
+ if Restriction_Active (No_Stream_Optimizations) then
+ Get_Tag :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Attribute_Name => Name_Input,
+ Expressions => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ else
+ Get_Tag :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_String_Input_Tag), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ end if;
+
Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
Parameter_Associations => New_List (
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_String_Input_Tag), Loc),
- Parameter_Associations => New_List (
- Relocate_Node (Duplicate_Subexpr (Strm)))),
-
+ Get_Tag,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (P_Type, Loc),
Attribute_Name => Name_Tag)));
when Attribute_Invalid_Value =>
Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
+ -- The value produced may be a conversion of a literal, which must be
+ -- resolved to establish its proper type.
+
+ Analyze_And_Resolve (N);
+
----------
-- Last --
----------
when Attribute_Max_Size_In_Storage_Elements => declare
Typ : constant Entity_Id := Etype (N);
Attr : Node_Id;
+ Atyp : Entity_Id;
Conversion_Added : Boolean := False;
-- A flag which tracks whether the original attribute has been
then
Set_Header_Size_Added (Attr);
+ Atyp := Etype (Attr);
+
-- Generate:
-- P'Max_Size_In_Storage_Elements +
- -- Universal_Integer
- -- (Header_Size_With_Padding (Ptyp'Alignment))
+ -- Atyp (Header_Size_With_Padding (Ptyp'Alignment))
Rewrite (Attr,
Make_Op_Add (Loc,
Left_Opnd => Relocate_Node (Attr),
Right_Opnd =>
- Convert_To (Universal_Integer,
+ Convert_To (Atyp,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Alignment))))));
+ Analyze_And_Resolve (Attr, Atyp);
+
-- Add a conversion to the target type
if not Conversion_Added then
- Rewrite (Attr,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Attr)));
+ Convert_To_And_Rewrite (Typ, Attr);
end if;
- Analyze (Attr);
return;
end if;
end;
-- Pos --
---------
- -- For enumeration types with a standard representation, Pos is
- -- handled by the back end.
+ -- For enumeration types with a standard representation, Pos is handled
+ -- by the back end.
-- For enumeration types, with a non-standard representation we generate
-- a call to the _Rep_To_Pos function created when the type was frozen.
- -- The call has the form
+ -- The call has the form:
-- _rep_to_pos (expr, flag)
-- Program_Error to be raised if the expression has an invalid
-- representation, and False if range checks are suppressed.
- -- For integer types, Pos is equivalent to a simple integer
- -- conversion and we rewrite it as such
+ -- For integer types, Pos is equivalent to a simple integer conversion
+ -- and we rewrite it as such.
when Attribute_Pos => Pos : declare
- Etyp : Entity_Id := Base_Type (Entity (Pref));
+ Etyp : Entity_Id := Base_Type (Ptyp);
begin
-- Deal with zero/non-zero boolean values
Rep_To_Pos_Flag (Ptyp, Loc))))));
else
- -- Add Boolean parameter True, to request program errror if
+ -- Add Boolean parameter True, to request program error if
-- we have a bad representation on our hands. If checks are
-- suppressed, then add False instead
Apply_Universal_Integer_Attribute_Checks (N);
end if;
+ ------------
+ -- Reduce --
+ ------------
+
+ when Attribute_Reduce =>
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ E1 : constant Node_Id := First (Expressions (N));
+ E2 : constant Node_Id := Next (E1);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Typ : constant Entity_Id := Etype (N);
+ New_Loop : Node_Id;
+
+ -- If the prefix is an aggregate, its unique component is an
+ -- Iterated_Element, and we create a loop out of its iterator.
+
+ begin
+ if Nkind (Prefix (N)) = N_Aggregate then
+ declare
+ Stream : constant Node_Id :=
+ First (Component_Associations (Prefix (N)));
+ Id : constant Node_Id := Defining_Identifier (Stream);
+ Expr : constant Node_Id := Expression (Stream);
+ Ch : constant Node_Id :=
+ First (Discrete_Choices (Stream));
+ begin
+ New_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Empty,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => New_Copy (Id),
+ Discrete_Subtype_Definition =>
+ Relocate_Node (Ch))),
+ End_Label => Empty,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (E1), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ Relocate_Node (Expr))))));
+ end;
+ else
+ -- If the prefix is a name, we construct an element iterator
+ -- over it. Its expansion will verify that it is an array or
+ -- a container with the proper aspects.
+
+ declare
+ Iter : Node_Id;
+ Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N);
+
+ begin
+ Iter :=
+ Make_Iterator_Specification (Loc,
+ Defining_Identifier => Elem,
+ Name => Relocate_Node (Prefix (N)),
+ Subtype_Indication => Empty);
+ Set_Of_Present (Iter);
+
+ New_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Iter,
+ Loop_Parameter_Specification => Empty),
+ End_Label => Empty,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (E1), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ New_Occurrence_Of (Elem, Loc))))));
+ end;
+ end if;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (E2)), New_Loop),
+ Expression => New_Occurrence_Of (Bnn, Loc)));
+ Analyze_And_Resolve (N, Typ);
+ end;
+
----------
-- Read --
----------
| Attribute_VADS_Size
=>
Size : declare
- Siz : Uint;
New_Node : Node_Id;
begin
Rewrite (N, New_Node);
Analyze_And_Resolve (N, Typ);
return;
-
- -- Case of known RM_Size of a type
-
- elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_RM_Size (Entity (Pref))
- then
- Siz := RM_Size (Entity (Pref));
-
- -- Case of known Esize of a type
-
- elsif Id = Attribute_Object_Size
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
-
- -- Case of known size of object
-
- elsif Id = Attribute_Size
- and then Is_Entity_Name (Pref)
- and then Is_Object (Entity (Pref))
- and then Known_Esize (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
-
- -- For an array component, we can do Size in the front end if the
- -- component_size of the array is set.
-
- elsif Nkind (Pref) = N_Indexed_Component then
- Siz := Component_Size (Etype (Prefix (Pref)));
-
- -- For a record component, we can do Size in the front end if
- -- there is a component clause, or if the record is packed and the
- -- component's size is known at compile time.
-
- elsif Nkind (Pref) = N_Selected_Component then
- declare
- Rec : constant Entity_Id := Etype (Prefix (Pref));
- Comp : constant Entity_Id := Entity (Selector_Name (Pref));
-
- begin
- if Present (Component_Clause (Comp)) then
- Siz := Esize (Comp);
-
- elsif Is_Packed (Rec) then
- Siz := RM_Size (Ptyp);
-
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- return;
- end if;
- end;
-
- -- All other cases are handled by the back end
-
- else
- Apply_Universal_Integer_Attribute_Checks (N);
-
- -- If Size is applied to a formal parameter that is of a packed
- -- array subtype, then apply Size to the actual subtype.
-
- if Is_Entity_Name (Pref)
- and then Is_Formal (Entity (Pref))
- and then Is_Array_Type (Ptyp)
- and then Is_Packed (Ptyp)
- then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
- Attribute_Name => Name_Size));
- Analyze_And_Resolve (N, Typ);
- end if;
-
- -- If Size applies to a dereference of an access to
- -- unconstrained packed array, the back end needs to see its
- -- unconstrained nominal type, but also a hint to the actual
- -- constrained type.
-
- if Nkind (Pref) = N_Explicit_Dereference
- and then Is_Array_Type (Ptyp)
- and then not Is_Constrained (Ptyp)
- and then Is_Packed (Ptyp)
- then
- Set_Actual_Designated_Subtype (Pref,
- Get_Actual_Subtype (Pref));
- end if;
-
- return;
end if;
- -- Common processing for record and array component case
-
- if Siz /= No_Uint and then Siz /= 0 then
- declare
- CS : constant Boolean := Comes_From_Source (N);
-
- begin
- Rewrite (N, Make_Integer_Literal (Loc, Siz));
+ -- Call Expand_Size_Attribute to do the final part of the
+ -- expansion which is shared with GNATprove expansion.
- -- This integer literal is not a static expression. We do
- -- not call Analyze_And_Resolve here, because this would
- -- activate the circuit for deciding that a static value
- -- was out of range, and we don't want that.
-
- -- So just manually set the type, mark the expression as
- -- non-static, and then ensure that the result is checked
- -- properly if the attribute comes from source (if it was
- -- internally generated, we never need a constraint check).
-
- Set_Etype (N, Typ);
- Set_Is_Static_Expression (N, False);
-
- if CS then
- Apply_Constraint_Check (N, Typ);
- end if;
- end;
- end if;
+ Expand_Size_Attribute (N);
end Size;
------------------
if Is_Access_Type (Ptyp) then
if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Max,
- Expressions => New_List (
- Make_Integer_Literal (Loc, 0),
- Convert_To (Typ,
+ Convert_To (Typ,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Etype (Storage_Size_Variable (Root_Type (Ptyp))), Loc),
+ Attribute_Name => Name_Max,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, 0),
New_Occurrence_Of
(Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
else
Rewrite (N,
- OK_Convert_To (Typ,
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Alloc_Op, Loc),
Make_Integer_Literal (Loc, 1))),
Rep_To_Pos_Flag (Ptyp, Loc))))));
else
- -- Add Boolean parameter True, to request program errror if
+ -- Add Boolean parameter True, to request program error if
-- we have a bad representation on our hands. Add False if
-- checks are suppressed.
----------------
-- Transforms System'To_Address (X) and System.Address'Ref (X) into
- -- unchecked conversion from (integral) type of X to type address.
+ -- unchecked conversion from (integral) type of X to type address. If
+ -- the To_Address is a static expression, the transformed expression
+ -- also needs to be static, because we do some legality checks (e.g.
+ -- for Thread_Local_Storage) after this transformation.
when Attribute_Ref
| Attribute_To_Address
=>
- Rewrite (N,
- Unchecked_Convert_To (RTE (RE_Address),
- Relocate_Node (First (Exprs))));
- Analyze_And_Resolve (N, RTE (RE_Address));
+ To_Address : declare
+ Is_Static : constant Boolean := Is_Static_Expression (N);
+
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (RTE (RE_Address),
+ Relocate_Node (First (Exprs))));
+ Set_Is_Static_Expression (N, Is_Static);
+
+ Analyze_And_Resolve (N, RTE (RE_Address));
+ end To_Address;
------------
-- To_Any --
------------
when Attribute_To_Any => To_Any : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
Rewrite (N,
Build_To_Any_Call
(Loc,
- Convert_To (P_Type,
+ Convert_To (Ptyp,
Relocate_Node (First (Exprs))), Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_Any));
--------------
when Attribute_TypeCode => TypeCode : declare
- P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
begin
- Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
+ Rewrite (N, Build_TypeCode_Call (Loc, Ptyp, Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_TypeCode));
end TypeCode;
-- Val --
---------
- -- For enumeration types with a standard representation, and for all
- -- other types, Val is handled by the back end. For enumeration types
- -- with a non-standard representation we use the _Pos_To_Rep array that
- -- was created when the type was frozen.
+ -- For enumeration types with a standard representation, Val is handled
+ -- by the back end.
+
+ -- For enumeration types with a non-standard representation we use the
+ -- _Pos_To_Rep array that was created when the type was frozen, unless
+ -- the representation is contiguous in which case we use an addition.
+
+ -- For integer types, Val is equivalent to a simple integer conversion
+ -- and we rewrite it as such.
when Attribute_Val => Val : declare
- Etyp : constant Entity_Id := Base_Type (Entity (Pref));
+ Etyp : constant Entity_Id := Base_Type (Ptyp);
+ Expr : constant Node_Id := First (Exprs);
begin
- if Is_Enumeration_Type (Etyp)
- and then Present (Enum_Pos_To_Rep (Etyp))
- then
- if Has_Contiguous_Rep (Etyp) then
- declare
- Rep_Node : constant Node_Id :=
- Unchecked_Convert_To (Etyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Etyp))),
- Right_Opnd =>
- (Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
+ -- Case of enumeration type
- begin
+ if Is_Enumeration_Type (Etyp) then
+
+ -- Non-standard enumeration type
+
+ if Present (Enum_Pos_To_Rep (Etyp)) then
+ if Has_Contiguous_Rep (Etyp) then
+ declare
+ Rep_Node : constant Node_Id :=
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ Convert_To (Standard_Integer, Expr)));
+
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => New_List (
+ Rep_Node,
+ Rep_To_Pos_Flag (Etyp, Loc))))));
+ end;
+
+ else
Rewrite (N,
- Unchecked_Convert_To (Etyp,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Etyp))),
- Right_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (TSS (Etyp, TSS_Rep_To_Pos), Loc),
- Parameter_Associations => New_List (
- Rep_Node,
- Rep_To_Pos_Flag (Etyp, Loc))))));
- end;
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer, Expr))));
+ end if;
- else
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
- Expressions => New_List (
- Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
- end if;
+ Analyze_And_Resolve (N, Typ);
- Analyze_And_Resolve (N, Typ);
+ -- Standard enumeration type
+
+ -- If the argument is marked as requiring a range check then
+ -- generate it here, after looking through a conversion to
+ -- universal integer, if any.
+
+ elsif Do_Range_Check (Expr) then
+ if Nkind (Expr) = N_Type_Conversion
+ and then Entity (Subtype_Mark (Expr)) = Universal_Integer
+ then
+ Generate_Range_Check
+ (Expression (Expr), Etyp, CE_Range_Check_Failed);
+ Set_Do_Range_Check (Expr, False);
+
+ else
+ Generate_Range_Check (Expr, Etyp, CE_Range_Check_Failed);
+ end if;
+ end if;
- -- If the argument is marked as requiring a range check then generate
- -- it here.
+ -- Deal with integer types
- elsif Do_Range_Check (First (Exprs)) then
- Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
+ elsif Is_Integer_Type (Etyp) then
+ Rewrite (N, Convert_To (Typ, Expr));
+ Analyze_And_Resolve (N, Typ);
end if;
end Val;
-- See separate sections below for the generated code in each case.
when Attribute_Valid => Valid : declare
- Btyp : Entity_Id := Base_Type (Ptyp);
+ PBtyp : Entity_Id := Base_Type (Ptyp);
Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
-- Save the validity checking mode. We always turn off validity
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
- -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
+ -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
---------------------
-- Make_Range_Test --
return
Make_In (Loc,
- Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
+ Left_Opnd => Unchecked_Convert_To (PBtyp, Temp),
Right_Opnd =>
Make_Range (Loc,
Low_Bound =>
- Unchecked_Convert_To (Btyp,
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
High_Bound =>
- Unchecked_Convert_To (Btyp,
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))));
-- Retrieve the base type. Handle the case where the base type is a
-- private enumeration type.
- if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
- Btyp := Full_View (Btyp);
+ if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then
+ PBtyp := Full_View (PBtyp);
end if;
-- Floating-point case. This case is handled by the Valid attribute
begin
-- The C and AAMP back-ends handle Valid for fpt types
- if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
+ if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then
Analyze_And_Resolve (Pref, Ptyp);
Set_Etype (N, Standard_Boolean);
Set_Analyzed (N);
-- The way we do the range check is simply to create the
-- expression: Valid (N) and then Base_Type(Pref) in Typ.
- if not Subtypes_Statically_Match (Ptyp, Btyp) then
+ if not Subtypes_Statically_Match (Ptyp, PBtyp) then
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
Right_Opnd =>
Make_In (Loc,
- Left_Opnd => Convert_To (Btyp, Pref),
+ Left_Opnd => Convert_To (PBtyp, Pref),
Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
end if;
end Float_Valid;
-- (X >= type(X)'First and then type(X)'Last <= X)
elsif Is_Enumeration_Type (Ptyp)
- and then Present (Enum_Pos_To_Rep (Btyp))
+ and then Present (Enum_Pos_To_Rep (PBtyp))
then
Tst :=
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
+ New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => New_List (
Pref,
New_Occurrence_Of (Standard_False, Loc))),
Right_Opnd => Make_Integer_Literal (Loc, 0));
- if Ptyp /= Btyp
+ if Ptyp /= PBtyp
and then
- (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
+ (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp)
or else
- Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
+ Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp))
then
-- The call to Make_Range_Test will create declarations
-- that need a proper insertion point, but Pref is now
-- test has to take this into account, and the proper form of the
-- test is:
- -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
+ -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
elsif Has_Biased_Representation (Ptyp) then
- Btyp := RTE (RE_Unsigned_32);
+ PBtyp := RTE (RE_Unsigned_32);
Rewrite (N,
Make_Op_Lt (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+ Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)),
Right_Opnd =>
- Unchecked_Convert_To (Btyp,
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Range_Length))));
-- the Valid attribute is exactly that this test does not work).
-- What will work is:
- -- Btyp!(X) >= Btyp!(type(X)'First)
+ -- PBtyp!(X) >= PBtyp!(type(X)'First)
-- and then
- -- Btyp!(X) <= Btyp!(type(X)'Last)
+ -- PBtyp!(X) <= PBtyp!(type(X)'Last)
- -- where Btyp is an integer type large enough to cover the full
+ -- where PBtyp is an integer type large enough to cover the full
-- range of possible stored values (i.e. it is chosen on the basis
-- of the size of the type, not the range of the values). We write
-- this as two tests, rather than a range check, so that static
-- correct, even though a value greater than 127 looks signed to a
-- signed comparison.
- elsif Is_Unsigned_Type (Ptyp) then
+ elsif Is_Unsigned_Type (Ptyp)
+ or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp))
+ then
if Esize (Ptyp) <= 32 then
- Btyp := RTE (RE_Unsigned_32);
+ PBtyp := RTE (RE_Unsigned_32);
else
- Btyp := RTE (RE_Unsigned_64);
+ PBtyp := RTE (RE_Unsigned_64);
end if;
Rewrite (N, Make_Range_Test);
else
if Esize (Ptyp) <= Esize (Standard_Integer) then
- Btyp := Standard_Integer;
+ PBtyp := Standard_Integer;
else
- Btyp := Universal_Integer;
+ PBtyp := Standard_Long_Long_Integer;
end if;
Rewrite (N, Make_Range_Test);
end if;
end Expand_Pred_Succ_Attribute;
+ ---------------------------
+ -- Expand_Size_Attribute --
+ ---------------------------
+
+ procedure Expand_Size_Attribute (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Pref : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (Pref);
+ Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
+ Siz : Uint;
+
+ begin
+ -- Case of known RM_Size of a type
+
+ if (Id = Attribute_Size or else Id = Attribute_Value_Size)
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_RM_Size (Entity (Pref))
+ then
+ Siz := RM_Size (Entity (Pref));
+
+ -- Case of known Esize of a type
+
+ elsif Id = Attribute_Object_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
+
+ -- Case of known size of object
+
+ elsif Id = Attribute_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Object (Entity (Pref))
+ and then Known_Esize (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
+
+ -- For an array component, we can do Size in the front end if the
+ -- component_size of the array is set.
+
+ elsif Nkind (Pref) = N_Indexed_Component then
+ Siz := Component_Size (Etype (Prefix (Pref)));
+
+ -- For a record component, we can do Size in the front end if there is a
+ -- component clause, or if the record is packed and the component's size
+ -- is known at compile time.
+
+ elsif Nkind (Pref) = N_Selected_Component then
+ declare
+ Rec : constant Entity_Id := Etype (Prefix (Pref));
+ Comp : constant Entity_Id := Entity (Selector_Name (Pref));
+
+ begin
+ if Present (Component_Clause (Comp)) then
+ Siz := Esize (Comp);
+
+ elsif Is_Packed (Rec) then
+ Siz := RM_Size (Ptyp);
+
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
+ return;
+ end if;
+ end;
+
+ -- All other cases are handled by the back end
+
+ else
+ -- If Size is applied to a formal parameter that is of a packed
+ -- array subtype, then apply Size to the actual subtype.
+
+ if Is_Entity_Name (Pref)
+ and then Is_Formal (Entity (Pref))
+ and then Is_Array_Type (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
+ Attribute_Name => Name_Size));
+ Analyze_And_Resolve (N, Typ);
+
+ -- If Size is applied to a dereference of an access to unconstrained
+ -- packed array, the back end needs to see its unconstrained nominal
+ -- type, but also a hint to the actual constrained type.
+
+ elsif Nkind (Pref) = N_Explicit_Dereference
+ and then Is_Array_Type (Ptyp)
+ and then not Is_Constrained (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref));
+
+ -- If Size was applied to a slice of a bit-packed array, we rewrite
+ -- it into the product of Length and Component_Size. We need to do so
+ -- because bit-packed arrays are represented internally as arrays of
+ -- System.Unsigned_Types.Packed_Byte for code generation purposes so
+ -- the size is always rounded up in the back end.
+
+ elsif Nkind (Pref) = N_Slice and then Is_Bit_Packed_Array (Ptyp) then
+ Rewrite (N,
+ Make_Op_Multiply (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Pref, True),
+ Attribute_Name => Name_Length),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Pref, True),
+ Attribute_Name => Name_Component_Size)));
+ Analyze_And_Resolve (N, Typ);
+ end if;
+
+ -- Apply the required checks last, after rewriting has taken place
+
+ Apply_Universal_Integer_Attribute_Checks (N);
+ return;
+ end if;
+
+ -- Common processing for record and array component case
+
+ if Siz /= No_Uint and then Siz /= 0 then
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+
+ begin
+ Rewrite (N, Make_Integer_Literal (Loc, Siz));
+
+ -- This integer literal is not a static expression. We do not
+ -- call Analyze_And_Resolve here, because this would activate
+ -- the circuit for deciding that a static value was out of range,
+ -- and we don't want that.
+
+ -- So just manually set the type, mark the expression as
+ -- nonstatic, and then ensure that the result is checked
+ -- properly if the attribute comes from source (if it was
+ -- internally generated, we never need a constraint check).
+
+ Set_Etype (N, Typ);
+ Set_Is_Static_Expression (N, False);
+
+ if CS then
+ Apply_Constraint_Check (N, Typ);
+ end if;
+ end;
+ end if;
+ end Expand_Size_Attribute;
+
-----------------------------
-- Expand_Update_Attribute --
-----------------------------
is
Base_Typ : constant Entity_Id := Base_Type (Typ);
Ent : constant Entity_Id := TSS (Typ, Nam);
-
- function Is_Available (Entity : RE_Id) return Boolean;
- pragma Inline (Is_Available);
- -- Function to check whether the specified run-time call is available
- -- in the run time used. In the case of a configurable run time, it
- -- is normal that some subprograms are not there.
- --
- -- I don't understand this routine at all, why is this not just a
- -- call to RTE_Available? And if for some reason we need a different
- -- routine with different semantics, why is not in Rtsfind ???
-
- ------------------
- -- Is_Available --
- ------------------
-
- function Is_Available (Entity : RE_Id) return Boolean is
- begin
- -- Assume that the unit will always be available when using a
- -- "normal" (not configurable) run time.
-
- return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
- end Is_Available;
-
- -- Start of processing for Find_Stream_Subprogram
-
begin
if Present (Ent) then
return Ent;
-- that stream routines for string types are not present (they require
-- file system support). In this case, the specific stream routines for
-- strings are not used, relying on the regular stream mechanism
- -- instead. That is why we include the test Is_Available when dealing
+ -- instead. That is why we include the test RTE_Available when dealing
-- with these cases.
if not Is_Predefined_Unit (Current_Sem_Unit) then
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Storage_Array_Input)
+ and then RTE_Available (RE_Storage_Array_Input)
then
return RTE (RE_Storage_Array_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Storage_Array_Output)
+ and then RTE_Available (RE_Storage_Array_Output)
then
return RTE (RE_Storage_Array_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Storage_Array_Read)
+ and then RTE_Available (RE_Storage_Array_Read)
then
return RTE (RE_Storage_Array_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Storage_Array_Write)
+ and then RTE_Available (RE_Storage_Array_Write)
then
return RTE (RE_Storage_Array_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Storage_Array_Input_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Input_Blk_IO)
then
return RTE (RE_Storage_Array_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Storage_Array_Output_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Output_Blk_IO)
then
return RTE (RE_Storage_Array_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Storage_Array_Read_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Read_Blk_IO)
then
return RTE (RE_Storage_Array_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Storage_Array_Write_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Write_Blk_IO)
then
return RTE (RE_Storage_Array_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Stream_Element_Array_Input)
+ and then RTE_Available (RE_Stream_Element_Array_Input)
then
return RTE (RE_Stream_Element_Array_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Stream_Element_Array_Output)
+ and then RTE_Available (RE_Stream_Element_Array_Output)
then
return RTE (RE_Stream_Element_Array_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Stream_Element_Array_Read)
+ and then RTE_Available (RE_Stream_Element_Array_Read)
then
return RTE (RE_Stream_Element_Array_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Stream_Element_Array_Write)
+ and then RTE_Available (RE_Stream_Element_Array_Write)
then
return RTE (RE_Stream_Element_Array_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Input_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Output_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Read_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Write_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_String_Input)
+ and then RTE_Available (RE_String_Input)
then
return RTE (RE_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_String_Output)
+ and then RTE_Available (RE_String_Output)
then
return RTE (RE_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_String_Read)
+ and then RTE_Available (RE_String_Read)
then
return RTE (RE_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_String_Write)
+ and then RTE_Available (RE_String_Write)
then
return RTE (RE_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_String_Input_Blk_IO)
+ and then RTE_Available (RE_String_Input_Blk_IO)
then
return RTE (RE_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_String_Output_Blk_IO)
+ and then RTE_Available (RE_String_Output_Blk_IO)
then
return RTE (RE_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_String_Read_Blk_IO)
+ and then RTE_Available (RE_String_Read_Blk_IO)
then
return RTE (RE_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_String_Write_Blk_IO)
+ and then RTE_Available (RE_String_Write_Blk_IO)
then
return RTE (RE_String_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_String_Input)
+ and then RTE_Available (RE_Wide_String_Input)
then
return RTE (RE_Wide_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_String_Output)
+ and then RTE_Available (RE_Wide_String_Output)
then
return RTE (RE_Wide_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_String_Read)
+ and then RTE_Available (RE_Wide_String_Read)
then
return RTE (RE_Wide_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_String_Write)
+ and then RTE_Available (RE_Wide_String_Write)
then
return RTE (RE_Wide_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_String_Input_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_String_Output_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_String_Read_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_String_Write_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_String_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_Wide_String_Input)
+ and then RTE_Available (RE_Wide_Wide_String_Input)
then
return RTE (RE_Wide_Wide_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_Wide_String_Output)
+ and then RTE_Available (RE_Wide_Wide_String_Output)
then
return RTE (RE_Wide_Wide_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_Wide_String_Read)
+ and then RTE_Available (RE_Wide_Wide_String_Read)
then
return RTE (RE_Wide_Wide_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_Wide_String_Write)
+ and then RTE_Available (RE_Wide_Wide_String_Write)
then
return RTE (RE_Wide_Wide_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Write_Blk_IO);
return False;
end if;
- -- Here we are in the integer conversion context
+ -- Here we are in the integer conversion context. We reuse Rounding for
+ -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
- -- Very probably we should also recognize the cases of Machine_Rounding
- -- and unbiased rounding in this conversion context, but the back end is
- -- not yet prepared to handle these cases ???
-
- return Id = Attribute_Rounding or else Id = Attribute_Truncation;
+ return
+ Id = Attribute_Rounding
+ or else Id = Attribute_Machine_Rounding
+ or else Id = Attribute_Truncation;
end Is_Inline_Floating_Point_Attribute;
end Exp_Attr;
projects / gcc.git / blobdiff