+2010-10-19 Javier Miranda <miranda@adacore.com>
+
+ * par-ch4.adb: Update documentation of Ada 2012 syntax rules for
+ membership test.
+
+2010-10-19 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Implement Max_Alignment_For_Allocation
+ attribute.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Add
+ Attribute_Max_Alignment_For_Allocation to the case statement.
+ * snames.ads-tmpl (Name_Max_Alignment_For_Allocation,
+ Attribute_Max_Alignment_For_Allocation): New attribute name.
+
+2010-10-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (OK_For_Limited_Init_In_05): a call to an access to
+ parameterless function appears syntactically as an explicit dereference.
+
+2010-10-19 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch8.adb, sem_ch12.adb, opt.ads, sem_ch6.adb, sem_res.adb,
+ i-cexten.ads, exp_disp.adb, exp_ch4.adb, exp_ch9.adb: Minor reformatting
+
+2010-10-19 Thomas Quinot <quinot@adacore.com>
+
+ * sem_util.adb (Collect_Primitive_Operations): A function with an
+ anonymous access result designating T is a primitive operation of T.
+
2010-10-19 Tristan Gingold <gingold@adacore.com>
* init.c: On Alpha/VMS, only adjust PC for HPARITH.
-- 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
-- GNAT
-- Used to record the storage pool name (or null literal) that is the
-- argument of an applicable pragma Default_Storage_Pool.
- -- Empty: No pragma Default_Storage_Pool applies.
+ -- Empty: No pragma Default_Storage_Pool applies.
-- N_Null node: "pragma Default_Storage_Pool (null);" applies.
- -- otherwise: "pragma Default_Storage_Pool (X);" applies, and
- -- this points to the name X.
- -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this.
+ -- otherwise: "pragma Default_Storage_Pool (X);" applies, and
+ -- this points to the name X.
+ -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value.
Detect_Blocking : Boolean := False;
-- GNAT
-- RELATION ::=
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
- -- | SIMPLE_EXPRESSION [not] in RANGE
- -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+ -- | SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
-- On return, Expr_Form indicates the categorization of the expression
-- P_Membership_Test --
-----------------------
+ -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
+ -- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
+
procedure P_Membership_Test (N : Node_Id) is
Alt : constant Node_Id :=
P_Range_Or_Subtype_Mark
Set_Etype (N, P_Base_Type);
----------------------------------
+ -- Max_Alignment_For_Allocation --
-- Max_Size_In_Storage_Elements --
----------------------------------
- when Attribute_Max_Size_In_Storage_Elements =>
+ when Attribute_Max_Alignment_For_Allocation |
+ Attribute_Max_Size_In_Storage_Elements =>
Check_E0;
Check_Type;
Check_Not_Incomplete_Type;
or else
Id = Attribute_Type_Class
or else
- Id = Attribute_Unconstrained_Array)
+ Id = Attribute_Unconstrained_Array
+ or else
+ Id = Attribute_Max_Alignment_For_Allocation)
and then not Is_Generic_Type (P_Entity)
then
P_Type := P_Entity;
then
Static := False;
- else
+ elsif Id /= Attribute_Max_Alignment_For_Allocation then
if not Is_Constrained (P_Type)
or else (Id /= Attribute_First and then
Id /= Attribute_Last and then
end Max;
----------------------------------
+ -- Max_Alignment_For_Allocation --
+ ----------------------------------
+
+ -- Max_Alignment_For_Allocation is usually the Alignment. However,
+ -- arrays are allocated with dope, so we need to take into account both
+ -- the alignment of the array, which comes from the component alignment,
+ -- and the alignment of the dope. Also, if the alignment is unknown, we
+ -- use the max (it's OK to be pessimistic).
+
+ when Attribute_Max_Alignment_For_Allocation =>
+ declare
+ A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
+ begin
+ if Known_Alignment (P_Type) and then
+ (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
+ then
+ A := Alignment (P_Type);
+ end if;
+
+ Fold_Uint (N, A, Static);
+ end;
+
+ ----------------------------------
-- Max_Size_In_Storage_Elements --
----------------------------------
end if;
end Width;
- -- The following attributes denote function that cannot be folded
+ -- The following attributes denote functions that cannot be folded
when Attribute_From_Any |
Attribute_To_Any |
then
declare
Renamed_Package : constant Node_Id :=
- Name (Parent (Entity (Gen_Id)));
+ Name (Parent (Entity (Gen_Id)));
begin
if Nkind (Renamed_Package) = N_Expanded_Name then
Inst_Par := Entity (Prefix (Renamed_Package));
-- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
-- case of limited aggregates (including extension aggregates), and
- -- function calls. The function call may have been give in prefixed
+ -- function calls. The function call may have been given in prefixed
-- notation, in which case the original node is an indexed component.
+ -- If the function is parameterless, the original node was an explicit
+ -- dereference.
case Nkind (Original_Node (Exp)) is
when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
OK_For_Limited_Init_In_05
(Typ, Expression (Original_Node (Exp)));
- when N_Indexed_Component | N_Selected_Component =>
+ when N_Indexed_Component | N_Selected_Component |
+ N_Explicit_Dereference =>
return Nkind (Exp) = N_Function_Call;
-- A use of 'Input is a function call, hence allowed. Normally the
end if;
Desig_1 := Find_Designated_Type (Type_1);
-
Desig_2 := Find_Designated_Type (Type_2);
-- If the context is an instance association for a formal
-- of an incomplete Class_Wide_Type are illegal.
if Is_Class_Wide_Type (Desig_1)
- and then Is_Class_Wide_Type (Desig_2)
+ and then
+ Is_Class_Wide_Type (Desig_2)
then
return
Conforming_Types
In_Scope := True;
-- The enclosing scope is not a synchronized type and the subprogram
- -- has no formals
+ -- has no formals.
elsif No (First_Formal (Def_Id)) then
return;
-- The subprogram has formals and hence it may be a primitive of a
- -- concurrent type
+ -- concurrent type.
else
Typ := Etype (First_Formal (Def_Id));
Subp : Entity_Id := Empty;
begin
- -- Traverse the homonym chain, looking at a potentially
+ -- Traverse the homonym chain, looking for a potentially
-- overridden subprogram that belongs to an implemented
-- interface.
null;
-- Entries and procedures can override abstract or null
- -- interface procedures
+ -- interface procedures.
elsif (Ekind (Def_Id) = E_Procedure
or else Ekind (Def_Id) = E_Entry)
Hom := Homonym (Hom);
end loop;
- -- After examining all candidates for overriding, we are
- -- left with the best match which is a mode incompatible
- -- interface routine. Do not emit an error if the Expander
- -- is active since this error will be detected later on
- -- after all concurrent types are expanded and all wrappers
- -- are built. This check is meant for spec-only
- -- compilations.
+ -- After examining all candidates for overriding, we are left with
+ -- the best match which is a mode incompatible interface routine.
+ -- Do not emit an error if the Expander is active since this error
+ -- will be detected later on after all concurrent types are
+ -- expanded and all wrappers are built. This check is meant for
+ -- spec-only compilations.
- if Present (Candidate)
- and then not Expander_Active
- then
+ if Present (Candidate) and then not Expander_Active then
Iface_Typ :=
Find_Parameter_Type (Parent (First_Formal (Candidate)));
- -- Def_Id is primitive of a protected type, declared
- -- inside the type, and the candidate is primitive of a
- -- limited or synchronized interface.
+ -- Def_Id is primitive of a protected type, declared inside the
+ -- type, and the candidate is primitive of a limited or
+ -- synchronized interface.
if In_Scope
and then Is_Protected_Type (Typ)
or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ))
then
- -- Must reword this message, comma before to in -gnatj
- -- mode ???
-
Error_Msg_NE
("first formal of & must be of mode `OUT`, `IN OUT`"
& " or access-to-variable", Typ, Candidate);
Error_Msg_N
- ("\to be overridden by protected procedure or entry "
- & "(RM 9.4(11.9/2))", Typ);
+ ("\in order to be overridden by protected procedure or "
+ & "entry (RM 9.4(11.9/2))", Typ);
end if;
end if;
-- Inside_Freeze_Actions is non zero when S corresponds with an
-- internal entity that links an interface primitive with its
-- covering primitive through attribute Interface_Alias (see
- -- Add_Internal_Interface_Entities)
+ -- Add_Internal_Interface_Entities).
if Inside_Freezing_Actions = 0
and then Is_Package_Or_Generic_Package (Current_Scope)
-- dispatch table anyway, because it can be dispatched to even if it
-- cannot be called directly.
- elsif Present (Alias (S))
- and then not Comes_From_Source (S)
- then
+ elsif Present (Alias (S)) and then not Comes_From_Source (S) then
Set_Scope (S, Current_Scope);
if Is_Dispatching_Operation (Alias (S)) then
then
declare
Aux : constant Node_Id :=
- Aux_Decls_Node (Parent (Unit_Declaration_Node (S)));
+ Aux_Decls_Node (Parent (Unit_Declaration_Node (S)));
begin
if No (Default_Storage_Pool (Aux)) then
Set_Default_Storage_Pool (Aux, Default_Pool);
then
declare
Aux : constant Node_Id :=
- Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
+ Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
begin
if Present (Default_Storage_Pool (Aux)) then
Default_Pool := Default_Storage_Pool (Aux);
Orig_T := Etype (Parent (N));
end if;
- -- if we have an entity name, then give the warning if the entity
+ -- If we have an entity name, then give the warning if the entity
-- is the right type, or if it is a loop parameter covered by the
-- original type (that's needed because loop parameters have an
-- odd subtype coming from the bounds).
null;
-- Finally, if this type conversion occurs in a context that
- -- requires a prefix, and the expression is a qualified
- -- expression, then the type conversion is not redundant,
- -- because a qualified expression is not a prefix, whereas a
- -- type conversion is. For example, "X := T'(Funx(...)).Y;" is
- -- illegal. because a selected component requires a prefix, but
- -- a type conversion makes it legal: "X := T(T'(Funx(...))).Y;"
+ -- requires a prefix, and the expression is a qualified expression
+ -- then the type conversion is not redundant, because a qualified
+ -- expression is not a prefix, whereas a type conversion is. For
+ -- example, "X := T'(Funx(...)).Y;" is illegal because a selected
+ -- component requires a prefix, but a type conversion makes it
+ -- legal: "X := T(T'(Funx(...))).Y;"
+
-- In Ada 2012, a qualified expression is a name, so this idiom is
-- no longer needed, but we still suppress the warning because it
-- seems unfriendly for warnings to pop up when you switch to the
-- be used when generating attributes of the string, for example
-- in the context of a slice assignment.
- Set_Etype (Index_Subtype, Base_Type (Index_Type));
- Set_Size_Info (Index_Subtype, Index_Type);
- Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
+ Set_Etype (Index_Subtype, Base_Type (Index_Type));
+ Set_Size_Info (Index_Subtype, Index_Type);
+ Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
Array_Subtype := Create_Itype (E_Array_Subtype, N);
-- ityp (x)
- -- with the Float_Truncate flag set, which is more efficient
+ -- with the Float_Truncate flag set, which is more efficient.
then
Rewrite (Operand,
-- Specifically test for validity of tagged conversions
function Valid_Array_Conversion return Boolean;
- -- Check index and component conformance, and accessibility levels
- -- if the component types are anonymous access types (Ada 2005)
+ -- Check index and component conformance, and accessibility levels if
+ -- the component types are anonymous access types (Ada 2005).
----------------------
-- Conversion_Check --
-- is no context type and the removal of the spurious operations
-- must be done explicitly here.
- -- The node may be labelled overloaded, but still contain only
- -- one interpretation because others were discarded in previous
- -- filters. If this is the case, retain the single interpretation
- -- if legal.
+ -- The node may be labelled overloaded, but still contain only one
+ -- interpretation because others were discarded earlier. If this
+ -- is the case, retain the single interpretation if legal.
Get_First_Interp (Operand, I, It);
Opnd_Type := It.Typ;
or else Opnd_Type = Any_Composite
or else Opnd_Type = Any_String
then
- Error_Msg_N
- ("illegal operand for array conversion", Operand);
+ Error_Msg_N ("illegal operand for array conversion", Operand);
return False;
else
return Valid_Array_Conversion;
end Check_Limited;
-- Access to subprogram types. If the operand is an access parameter,
- -- the type has a deeper accessibility that any master, and cannot
- -- be assigned. We must make an exception if the conversion is part
- -- of an assignment and the target is the return object of an extended
- -- return statement, because in that case the accessibility check
- -- takes place after the return.
+ -- the type has a deeper accessibility that any master, and cannot be
+ -- assigned. We must make an exception if the conversion is part of an
+ -- assignment and the target is the return object of an extended return
+ -- statement, because in that case the accessibility check takes place
+ -- after the return.
elsif Is_Access_Subprogram_Type (Target_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
-- If both are tagged types, check legality of view conversions
elsif Is_Tagged_Type (Target_Type)
- and then Is_Tagged_Type (Opnd_Type)
+ and then
+ Is_Tagged_Type (Opnd_Type)
then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;
- -- In an instance or an inlined body, there may be inconsistent
- -- views of the same type, or of types derived from a common root.
+ -- In an instance or an inlined body, there may be inconsistent views of
+ -- the same type, or of types derived from a common root.
elsif (In_Instance or In_Inlined_Body)
and then
Formal_Derived : Boolean := False;
Id : Entity_Id;
+ function Match (E : Entity_Id) return Boolean;
+ -- True if E's base type is B_Type, or E is of an anonymous access type
+ -- and the base type of its designated type is B_Type.
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (E : Entity_Id) return Boolean is
+ Etyp : Entity_Id := Etype (E);
+
+ begin
+ if Ekind (Etyp) = E_Anonymous_Access_Type then
+ Etyp := Designated_Type (Etyp);
+ end if;
+
+ return Base_Type (Etyp) = B_Type;
+ end Match;
+
+ -- Start of processing for Collect_Primitive_Operations
+
begin
-- For tagged types, the primitive operations are collected as they
-- are declared, and held in an explicit list which is simply returned.
then
Is_Prim := False;
- if Base_Type (Etype (Id)) = B_Type then
+ if Match (Id) then
Is_Prim := True;
+
else
Formal := First_Formal (Id);
while Present (Formal) loop
- if Base_Type (Etype (Formal)) = B_Type then
- Is_Prim := True;
- exit;
-
- elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- and then Base_Type
- (Designated_Type (Etype (Formal))) = B_Type
- then
+ if Match (Formal) then
Is_Prim := True;
exit;
end if;
Name_Machine_Rounds : constant Name_Id := N + $;
Name_Machine_Size : constant Name_Id := N + $; -- GNAT
Name_Mantissa : constant Name_Id := N + $; -- Ada 83
+ Name_Max_Alignment_For_Allocation : constant Name_Id := N + $; -- Ada 12
Name_Max_Size_In_Storage_Elements : constant Name_Id := N + $;
Name_Maximum_Alignment : constant Name_Id := N + $; -- GNAT
Name_Mechanism_Code : constant Name_Id := N + $; -- GNAT
Attribute_Machine_Rounds,
Attribute_Machine_Size,
Attribute_Mantissa,
+ Attribute_Max_Alignment_For_Allocation,
Attribute_Max_Size_In_Storage_Elements,
Attribute_Maximum_Alignment,
Attribute_Mechanism_Code,
projects / platform / upstream / linaro-gcc.git / commitdiff