-----------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Pkind : constant Node_Kind := Nkind (Parent (N));
Aggr_Subtyp : Entity_Id;
Next (Expr);
end loop;
- Rewrite (N,
- Make_String_Literal (Sloc (N), End_String));
+ Rewrite (N, Make_String_Literal (Loc, End_String));
Analyze_And_Resolve (N, Typ);
return;
-- subtype for the final aggregate.
begin
- -- In the following we determine whether an others choice is
+ -- In the following we determine whether an OTHERS choice is
-- allowed inside the array aggregate. The test checks the context
-- in which the array aggregate occurs. If the context does not
- -- permit it, or the aggregate type is unconstrained, an others
+ -- permit it, or the aggregate type is unconstrained, an OTHERS
-- choice is not allowed.
-- If expansion is disabled (generic context, or semantics-only
-- mode) actual subtypes cannot be constructed, and the type of an
-- object may be its unconstrained nominal type. However, if the
- -- context is an assignment, we assume that "others" is allowed,
+ -- context is an assignment, we assume that OTHERS is allowed,
-- because the target of the assignment will have a constrained
-- subtype when fully compiled.
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => True);
+
else
Aggr_Resolved :=
Resolve_Array_Aggregate
if Raises_Constraint_Error (N) then
Aggr_Subtyp := Etype (N);
Rewrite (N,
- Make_Raise_Constraint_Error (Sloc (N),
+ Make_Raise_Constraint_Error (Loc,
Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (N);
Set_Etype (N, Aggr_Subtyp);
-- analyzed expression.
procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
- -- Checks that AH (the upper bound of an array aggregate) is <= BH
- -- (the upper bound of the index base type). If the check fails a
- -- warning is emitted, the Raises_Constraint_Error flag of N is set,
- -- and AH is replaced with a duplicate of BH.
+ -- Checks that AH (the upper bound of an array aggregate) is less than
+ -- or equal to BH (the upper bound of the index base type). If the check
+ -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is
+ -- set, and AH is replaced with a duplicate of BH.
procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
-- Checks that range AL .. AH is compatible with range L .. H. Emits a
-- Resolves aggregate expression Expr. Returns False if resolution
-- fails. If Single_Elmt is set to False, the expression Expr may be
-- used to initialize several array aggregate elements (this can happen
- -- for discrete choices such as "L .. H => Expr" or the others choice).
+ -- for discrete choices such as "L .. H => Expr" or the OTHERS choice).
-- In this event we do not resolve Expr unless expansion is disabled.
-- To know why, see the DELAYED COMPONENT RESOLUTION note above.
if not Is_Enumeration_Type (Index_Base) then
Expr :=
Make_Op_Add (Loc,
- Left_Opnd => Duplicate_Subexpr (To),
- Right_Opnd => Make_Integer_Literal (Loc, Val));
+ Left_Opnd => Duplicate_Subexpr (To),
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
-- If we are dealing with enumeration return
-- Index_Typ'Val (Index_Typ'Pos (To) + Val)
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (Expr_Pos));
+
+ -- If the index type has a non standard representation, the
+ -- attributes 'Val and 'Pos expand into function calls and the
+ -- resulting expression is considered non-safe for reevaluation
+ -- by the backend. Relocate it into a constant temporary in order
+ -- to make it safe for reevaluation.
+
+ if Has_Non_Standard_Rep (Etype (N)) then
+ declare
+ Def_Id : Entity_Id;
+
+ begin
+ Def_Id := Make_Temporary (Loc, 'R', Expr);
+ Set_Etype (Def_Id, Index_Typ);
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Reference_To (Index_Typ, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Expr)));
+
+ Expr := New_Reference_To (Def_Id, Loc);
+ end;
+ end if;
end if;
return Expr;
end loop;
end if;
- if Present (Old_Disc) then
+ if Present (Old_Disc) and then Expander_Active then
-- The new type has fewer discriminants, so we need to create a new
-- corresponding record, which is derived from the corresponding
-- record of the parent, and has a stored constraint that captures
-- the values of the discriminant constraints.
+ -- The corresponding record is needed only if expander is active
+ -- and code generation is enabled.
- -- The type declaration for the derived corresponding record has
- -- the same discriminant part and constraints as the current
- -- declaration. Copy the unanalyzed tree to build declaration.
+ -- The type declaration for the derived corresponding record has the
+ -- same discriminant part and constraints as the current declaration.
+ -- Copy the unanalyzed tree to build declaration.
Corr_Decl_Needed := True;
New_N := Copy_Separate_Tree (N);
Corr_Decl :=
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Corr_Record,
+ Defining_Identifier => Corr_Record,
Discriminant_Specifications =>
Discriminant_Specifications (New_N),
- Type_Definition =>
+ Type_Definition =>
Make_Derived_Type_Definition (Loc,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(Corresponding_Record_Type (Parent_Type), Loc),
- Constraint =>
+ Constraint =>
Constraint
(Subtype_Indication (Type_Definition (New_N))))));
end if;