From aee37720d3214d4a2d69b6597d7c7f1f76e09af1 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 19 Oct 2010 10:30:18 +0000 Subject: [PATCH] 2010-10-19 Javier Miranda * par-ch4.adb: Update documentation of Ada 2012 syntax rules for membership test. 2010-10-19 Bob Duff * 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 * 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 * 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 * sem_util.adb (Collect_Primitive_Operations): A function with an anonymous access result designating T is a primitive operation of T. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165692 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 29 ++++++++++++++++++++++++++ gcc/ada/exp_attr.adb | 4 ++-- gcc/ada/opt.ads | 8 ++++---- gcc/ada/par-ch4.adb | 6 ++++-- gcc/ada/sem_attr.adb | 35 ++++++++++++++++++++++++++++---- gcc/ada/sem_ch12.adb | 2 +- gcc/ada/sem_ch3.adb | 7 +++++-- gcc/ada/sem_ch6.adb | 48 ++++++++++++++++++------------------------- gcc/ada/sem_ch8.adb | 4 ++-- gcc/ada/sem_res.adb | 54 ++++++++++++++++++++++++------------------------- gcc/ada/sem_util.adb | 33 +++++++++++++++++++++--------- gcc/ada/snames.ads-tmpl | 2 ++ 12 files changed, 151 insertions(+), 81 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 52d6191..b431a34 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2010-10-19 Javier Miranda + + * par-ch4.adb: Update documentation of Ada 2012 syntax rules for + membership test. + +2010-10-19 Bob Duff + + * 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 + + * 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 + + * 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 + + * 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 * init.c: On Alpha/VMS, only adjust PC for HPARITH. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7b29d7a..8d23fa3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5310,8 +5310,8 @@ package body Exp_Attr is -- 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 diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 11def2f..d574373 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -363,11 +363,11 @@ package Opt is -- 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 diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index bcffe80..5069fd1 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1739,8 +1739,7 @@ package body Ch4 is -- 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 @@ -2882,6 +2881,9 @@ package body Ch4 is -- 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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f520b4b..264ea69 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3420,10 +3420,12 @@ package body Sem_Attr is 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; @@ -5589,7 +5591,9 @@ package body Sem_Attr is 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; @@ -5714,7 +5718,7 @@ package body Sem_Attr is 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 @@ -6624,6 +6628,29 @@ package body Sem_Attr is 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 -- ---------------------------------- @@ -7641,7 +7668,7 @@ package body Sem_Attr is 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 | diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4b15644..e8c1741 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5320,7 +5320,7 @@ package body Sem_Ch12 is 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)); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a54393a..1325b91 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16016,8 +16016,10 @@ package body Sem_Ch3 is -- 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 => @@ -16042,7 +16044,8 @@ package body Sem_Ch3 is 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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a23aac9..7dc72f3 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5472,7 +5472,6 @@ package body Sem_Ch6 is 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 @@ -5493,7 +5492,8 @@ package body Sem_Ch6 is -- 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 @@ -7518,13 +7518,13 @@ package body Sem_Ch6 is 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)); @@ -7573,7 +7573,7 @@ package body Sem_Ch6 is 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. @@ -7591,7 +7591,7 @@ package body Sem_Ch6 is 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) @@ -7652,23 +7652,20 @@ package body Sem_Ch6 is 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) @@ -7678,15 +7675,12 @@ package body Sem_Ch6 is 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; @@ -7775,7 +7769,7 @@ package body Sem_Ch6 is -- 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) @@ -7846,9 +7840,7 @@ package body Sem_Ch6 is -- 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0e9d0b4..10b7664 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6651,7 +6651,7 @@ package body Sem_Ch8 is 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); @@ -6802,7 +6802,7 @@ package body Sem_Ch8 is 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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ab56c61..da8f638 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8880,7 +8880,7 @@ package body Sem_Res is 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). @@ -8908,12 +8908,13 @@ package body Sem_Res is 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 @@ -9515,9 +9516,9 @@ package body Sem_Res is -- 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); @@ -9568,7 +9569,7 @@ package body Sem_Res is -- 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, @@ -9696,8 +9697,8 @@ package body Sem_Res is -- 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 -- @@ -9931,10 +9932,9 @@ package body Sem_Res is -- 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; @@ -10049,8 +10049,7 @@ package body Sem_Res is 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; @@ -10342,11 +10341,11 @@ package body Sem_Res is 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)) @@ -10434,7 +10433,8 @@ package body Sem_Res is -- 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); @@ -10443,8 +10443,8 @@ package body Sem_Res is 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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d278e1d..53726d4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1693,6 +1693,27 @@ package body Sem_Util is 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. @@ -1761,19 +1782,13 @@ package body Sem_Util is 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; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b8ea329..0223c1e 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -764,6 +764,7 @@ package Snames is 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 @@ -1282,6 +1283,7 @@ package Snames is 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, -- 2.7.4