diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 25 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 181 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 23 | ||||
| -rw-r--r-- | gcc/ada/par-ch12.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 123 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 17 |
17 files changed, 345 insertions, 118 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2dfcb64a41d..f4208df878e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2014-02-24 Robert Dewar <dewar@adacore.com> + + * sinfo.ads, sem_ch12.adb, sem_res.adb, sem_ch4.adb, par-ch12.adb: + Minor reformatting. + * atree.ads, atree.adb (Node35): New function. + (Set_Node35): New procedure. + * debug.adb: Define new debug flag -gnatd.X. + * einfo.ads, einfo.adb (Import_Pragma): New field. + * freeze.adb (Wrap_Imported_Procedure): New procedure (not + really active yet, has to be activated with -gnatd.X. + * sem_prag.adb (Set_Imported): Set new Import_Pragma + field (Set_Imported): Don't set Is_Public (see + Freeze.Wrap_Imported_Subprogram) + * par-ch3.adb (P_Component_List): Handle unexpected null component. + +2014-02-24 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb: Correct reference to SPARK RM in error messages. + * gnat_rm.texi: Correct documentation of attribute Update. + +2014-02-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Iterator_Specification): Reject container + iterator in older versions of Ada. + 2014-02-24 Gary Dismukes <dismukes@adacore.com> * sem_ch5.adb, sem_aux.ads, sem_ch12.adb, gnat_ugn.texi, par.adb, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 9e7897e79aa..2e3f76b5c64 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2643,6 +2643,12 @@ package body Atree is return Node_Id (Nodes.Table (N + 5).Field10); end Node34; + function Node35 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 5).Field11); + end Node35; + function List1 (N : Node_Id) return List_Id is begin pragma Assert (N <= Nodes.Last); @@ -5407,6 +5413,12 @@ package body Atree is Nodes.Table (N + 5).Field10 := Union_Id (Val); end Set_Node34; + procedure Set_Node35 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 5).Field11 := Union_Id (Val); + end Set_Node35; + procedure Set_List1 (N : Node_Id; Val : List_Id) is begin pragma Assert (N <= Nodes.Last); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 0603d113b4b..ba110825b39 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -1236,6 +1236,9 @@ package Atree is function Node34 (N : Node_Id) return Node_Id; pragma Inline (Node34); + function Node35 (N : Node_Id) return Node_Id; + pragma Inline (Node35); + function List1 (N : Node_Id) return List_Id; pragma Inline (List1); @@ -2545,6 +2548,9 @@ package Atree is procedure Set_Node34 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node34); + procedure Set_Node35 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node35); + procedure Set_List1 (N : Node_Id; Val : List_Id); pragma Inline (Set_List1); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 11237e23dc9..a6506932982 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -141,7 +141,7 @@ package body Debug is -- d.U Ignore indirect calls for static elaboration -- d.V -- d.W Print out debugging information for Walk_Library_Items - -- d.X + -- d.X Activate wrapping of imported subprograms with pre/post conditions -- d.Y -- d.Z @@ -664,6 +664,9 @@ package body Debug is -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. + -- d.X Activates Wrap_Imported_Subprogram in Freeze (not yet working so + -- this allows checkin of partial implementation). + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 1502d446aad..01ec45a457d 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -257,7 +257,7 @@ package body Einfo is -- Contract Node34 - -- (unused) Node35 + -- Import_Pragma Node35 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- @@ -1785,6 +1785,12 @@ package body Einfo is return Node4 (Id); end Homonym; + function Import_Pragma (Id : E) return E is + begin + pragma Assert (Is_Subprogram (Id)); + return Node35 (Id); + end Import_Pragma; + function Interface_Alias (Id : E) return E is begin pragma Assert (Is_Subprogram (Id)); @@ -4483,6 +4489,12 @@ package body Einfo is Set_Node4 (Id, V); end Set_Homonym; + procedure Set_Import_Pragma (Id : E; V : E) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Node35 (Id, V); + end Set_Import_Pragma; + procedure Set_Interface_Alias (Id : E; V : E) is begin pragma Assert @@ -9554,6 +9566,8 @@ package body Einfo is procedure Write_Field35_Name (Id : Entity_Id) is begin case Ekind (Id) is + when Subprogram_Kind => + Write_Str ("Import_Pragma"); when others => Write_Str ("Field35??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9fef149ecca..00cc1fab424 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1973,6 +1973,13 @@ package Einfo is -- that we still have a concrete type. For entities other than types, -- returns the entity unchanged. +-- Import_Pragma (Node35) +-- Defined in subprogram entities. Set if a valid pragma Import or pragma +-- Import_Function or pragma Import_Procedure aplies to the subprogram, +-- in which case this field points to the pragma (we can't use the normal +-- Rep_Item chain mechanism, because a single pragma Import can apply +-- to multiple subprogram entities. + -- In_Package_Body (Flag48) -- Defined in package entities. Set on the entity that denotes the -- package (the defining occurrence of the package declaration) while @@ -6478,6 +6485,7 @@ package Einfo is function Has_Xref_Entry (Id : E) return B; function Hiding_Loop_Variable (Id : E) return E; function Homonym (Id : E) return E; + function Import_Pragma (Id : E) return E; function In_Package_Body (Id : E) return B; function In_Private_Part (Id : E) return B; function In_Use (Id : E) return B; @@ -7100,6 +7108,7 @@ package Einfo is procedure Set_Has_Xref_Entry (Id : E; V : B := True); procedure Set_Hiding_Loop_Variable (Id : E; V : E); procedure Set_Homonym (Id : E; V : E); + procedure Set_Import_Pragma (Id : E; V : E); procedure Set_In_Package_Body (Id : E; V : B := True); procedure Set_In_Private_Part (Id : E; V : B := True); procedure Set_In_Use (Id : E; V : B := True); @@ -7836,6 +7845,7 @@ package Einfo is pragma Inline (Has_Xref_Entry); pragma Inline (Hiding_Loop_Variable); pragma Inline (Homonym); + pragma Inline (Import_Pragma); pragma Inline (In_Package_Body); pragma Inline (In_Private_Part); pragma Inline (In_Use); @@ -8306,6 +8316,7 @@ package Einfo is pragma Inline (Set_Has_Xref_Entry); pragma Inline (Set_Hiding_Loop_Variable); pragma Inline (Set_Homonym); + pragma Inline (Set_Import_Pragma); pragma Inline (Set_In_Package_Body); pragma Inline (Set_In_Private_Part); pragma Inline (Set_In_Use); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 294f64cce47..716a96b42a6 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1742,6 +1742,11 @@ package body Freeze is -- Freeze record type, including freezing component types, and freezing -- primitive operations if this is a tagged type. + procedure Wrap_Imported_Subprogram (E : Entity_Id); + -- If E is an entity for an imported subprogram with pre/post-conditions + -- then this procedure will create a wrapper to ensure that proper run- + -- time checking of the pre/postconditions. See body for details. + ------------------- -- Add_To_Result -- ------------------- @@ -3358,6 +3363,146 @@ package body Freeze is end Check_Variant_Part; end Freeze_Record_Type; + ------------------------------ + -- Wrap_Imported_Subprogram -- + ------------------------------ + + -- The issue here is that our normal approach of checking preconditions + -- and postconditions does not work for imported procedures, since we + -- are not generating code for the body. To get around this we create + -- a wrapper, as shown by the following example: + + -- procedure K (A : Integer); + -- pragma Import (C, K); + + -- The spec is rewritten by removing the effects of pragma Import, but + -- leaving the convention unchanged, as though the source had said: + + -- procedure K (A : Integer); + -- pragma Convention (C, K); + + -- and we create a body, added to the entity K freeze actions, which + -- looks like: + + -- procedure K (A : Integer) is + -- procedure K (A : Integer); + -- pragma Import (C, K); + -- begin + -- K (A); + -- end K; + + -- Now the contract applies in the normal way to the outer procedure, + -- and the inner procedure has no contracts, so there is no problem + -- in just calling it to get the original effect. + + -- In the case of a function, we create an appropriate return statement + -- for the subprogram body that calls the inner procedure. + + procedure Wrap_Imported_Subprogram (E : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + Spec : Node_Id; + Parms : List_Id; + Stmt : Node_Id; + Iprag : Node_Id; + Bod : Node_Id; + Forml : Entity_Id; + + begin + -- Nothing to do if not imported + + if not Is_Imported (E) then + return; + end if; + + -- Test enabling conditions for wrapping + + if Is_Subprogram (E) + and then Present (Contract (E)) + and then Present (Pre_Post_Conditions (Contract (E))) + and then not GNATprove_Mode + then + -- For now, activate this only if -gnatd.X is set, because there + -- are problems with this procedure, it is not working yet, but + -- we would like to be able to check it in ??? + + if not Debug_Flag_Dot_XX then + Error_Msg_NE + ("pre/post conditions on imported subprogram are not " + & "enforced??", E, Pre_Post_Conditions (Contract (E))); + goto Not_Wrapped; + end if; + + -- Fix up spec to be not imported any more + + Iprag := Import_Pragma (E); + Set_Is_Imported (E, False); + Set_Interface_Name (E, Empty); + Set_Has_Completion (E, False); + Set_Import_Pragma (E, Empty); + + -- Grab the subprogram declaration and specification + + Spec := Declaration_Node (E); + + -- Build parameter list that we need + + Parms := New_List; + Forml := First_Formal (E); + while Present (Forml) loop + Append_To (Parms, New_Occurrence_Of (Forml, Loc)); + Next_Formal (Forml); + end loop; + + -- Build the call + + if Ekind_In (E, E_Function, E_Generic_Function) then + Stmt := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (E, Loc), + Parameter_Associations => Parms)); + + else + Stmt := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (E, Loc), + Parameter_Associations => Parms); + end if; + + -- Now build the body + + Bod := + Make_Subprogram_Body (Loc, + Specification => Copy_Separate_Tree (Spec), + Declarations => New_List ( + Make_Subprogram_Declaration (Loc, + Specification => Copy_Separate_Tree (Spec)), + Copy_Separate_Tree (Iprag)), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Stmt), + End_Label => New_Occurrence_Of (E, Loc))); + + -- Append the body to freeze result + + Add_To_Result (Bod); + return; + end if; + + -- Case of imported subprogram that does not get wrapped + + <<Not_Wrapped>> + + -- Set Is_Public. All imported entities need an external symbol + -- created for them since they are always referenced from another + -- object file. Note this used to be set when we set Is_Imported + -- back in Sem_Prag, but now we delay it to this point, since we + -- don't want to set this flag if we wrap an imported subprogram. + + Set_Is_Public (E); + end Wrap_Imported_Subprogram; + -- Start of processing for Freeze_Entity begin @@ -3539,13 +3684,19 @@ package body Freeze is null; end if; - -- For a subprogram, freeze all parameter types and also the return - -- type (RM 13.14(14)). However skip this for internal subprograms. - -- This is also the point where any extra formal parameters are - -- created since we now know whether the subprogram will use a - -- foreign convention. + -- Subprogram case if Is_Subprogram (E) then + + -- Check for needing to wrap imported subprogram + + Wrap_Imported_Subprogram (E); + + -- Freeze all parameter types and the return type (RM 13.14(14)). + -- However skip this for internal subprograms. This is also where + -- any extra formal parameters are created since we now know + -- whether the subprogram will use a foreign convention. + if not Is_Internal (E) then declare F_Type : Entity_Id; @@ -3867,26 +4018,6 @@ package body Freeze is end if; end if; end; - - -- Pre/post conditions are implemented through a subprogram - -- in the corresponding body, and therefore are not checked on - -- an imported subprogram for which the body is not available. - -- This warning is not issued in GNATprove mode, as all these - -- contracts are handled in formal verification, so the warning - -- would be misleading in that case. - - -- Could consider generating a wrapper to take care of this??? - - if Is_Subprogram (E) - and then Is_Imported (E) - and then Present (Contract (E)) - and then Present (Pre_Post_Conditions (Contract (E))) - and then not GNATprove_Mode - then - Error_Msg_NE - ("pre/post conditions on imported subprogram are not " - & "enforced??", E, Pre_Post_Conditions (Contract (E))); - end if; end if; -- Must freeze its parent first if it is a derived subprogram diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 2b71259edb9..af51de8adbd 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -9286,14 +9286,21 @@ The @code{Update} attribute creates a copy of an array or record value with one or more modified components. The syntax is: @smallexample @c ada -PREFIX'Update (AGGREGATE) +PREFIX'Update ( RECORD_COMPONENT_ASSOCIATION_LIST ) +PREFIX'Update ( ARRAY_COMPONENT_ASSOCIATION @{, ARRAY_COMPONENT_ASSOCIATION @} ) +PREFIX'Update ( MULTIDIMENSIONAL_ARRAY_COMPONENT_ASSOCIATION + @{, MULTIDIMENSIONAL_ARRAY_COMPONENT_ASSOCIATION @} ) + +MULTIDIMENSIONAL_ARRAY_COMPONENT_ASSOCIATION ::= INDEX_EXPRESSION_LIST_LIST => EXPRESSION +INDEX_EXPRESSION_LIST_LIST ::= INDEX_EXPRESSION_LIST @{| INDEX_EXPRESSION_LIST @} +INDEX_EXPRESSION_LIST ::= ( EXPRESSION @{, EXPRESSION @} ) @end smallexample @noindent where @code{PREFIX} is the name of an array or record object, and -@code{AGGREGATE} is a named aggregate that does not contain an @code{others} +the association list in parentheses does not contain an @code{others} choice. The effect is to yield a copy of the array or record value which -is unchanged apart from the components mentioned in the aggregate, which +is unchanged apart from the components mentioned in the association list, which are changed to the indicated value. The original value of the array or record value is not affected. For example: @@ -9301,7 +9308,7 @@ record value is not affected. For example: type Arr is Array (1 .. 5) of Integer; ... Avar1 : Arr := (1,2,3,4,5); -Avar2 : Arr := Avar1'Update ((2 => 10, 3 .. 4 => 20)); +Avar2 : Arr := Avar1'Update (2 => 10, 3 .. 4 => 20); @end smallexample @noindent @@ -9312,7 +9319,7 @@ begin unmodified. Similarly: type Rec is A, B, C : Integer; ... Rvar1 : Rec := (A => 1, B => 2, C => 3); -Rvar2 : Rec := Rvar1'Update ((B => 20)); +Rvar2 : Rec := Rvar1'Update (B => 20); @end smallexample @noindent @@ -9322,7 +9329,7 @@ Note that the value of the attribute reference is computed completely before it is used. This means that if you write: @smallexample @c ada -Avar1 := Avar1'Update ((1 => 10, 2 => Function_Call)); +Avar1 := Avar1'Update (1 => 10, 2 => Function_Call); @end smallexample @noindent @@ -9338,7 +9345,7 @@ The accessibility level of an Update attribute result object is defined as for an aggregate. In the record case, no component can be mentioned more than once. In -the array case, two overlapping ranges can appear in the aggregate, +the array case, two overlapping ranges can appear in the association list, in which case the modifications are processed left to right. Multi-dimensional arrays can be modified, as shown by this example: @@ -9346,7 +9353,7 @@ Multi-dimensional arrays can be modified, as shown by this example: @smallexample @c ada A : array (1 .. 10, 1 .. 10) of Integer; .. -A := A'Update (1 => (2 => 20), 3 => (4 => 30)); +A := A'Update ((1, 2) => 20, (3, 4) => 30); @end smallexample @noindent diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index e13216ac880..839697c7663 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -350,8 +350,8 @@ package body Ch12 is if Token = Tok_Others then if Ada_Version < Ada_2005 then Error_Msg_SP - ("partial parameterization of formal packages" & - " is an Ada 2005 extension"); + ("partial parameterization of formal packages" + & " is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index c09a68fbb2f..11e9f81c4d1 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -3270,87 +3270,100 @@ package body Ch3 is Component_List_Node : Node_Id; Decls_List : List_Id; Scan_State : Saved_Scan_State; + Null_Loc : Source_Ptr; begin Component_List_Node := New_Node (N_Component_List, Token_Ptr); Decls_List := New_List; + -- Handle null + if Token = Tok_Null then + Null_Loc := Token_Ptr; Scan; -- past NULL TF_Semicolon; P_Pragmas_Opt (Decls_List); - Set_Null_Present (Component_List_Node, True); - return Component_List_Node; - else - P_Pragmas_Opt (Decls_List); + -- If we have an END or WHEN now, everything is fine, otherwise we + -- complain about the null, ignore it, and scan for more components. - if Token /= Tok_Case then - Component_Scan_Loop : loop - P_Component_Items (Decls_List); - P_Pragmas_Opt (Decls_List); - - exit Component_Scan_Loop when Token = Tok_End - or else Token = Tok_Case - or else Token = Tok_When; - - -- We are done if we do not have an identifier. However, if - -- we have a misspelled reserved identifier that is in a column - -- to the right of the record definition, we will treat it as - -- an identifier. It turns out to be too dangerous in practice - -- to accept such a mis-spelled identifier which does not have - -- this additional clue that confirms the incorrect spelling. - - if Token /= Tok_Identifier then - if Start_Column > Scope.Table (Scope.Last).Ecol - and then Is_Reserved_Identifier - then - Save_Scan_State (Scan_State); -- at reserved id - Scan; -- possible reserved id + if Token = Tok_End or else Token = Tok_When then + Set_Null_Present (Component_List_Node, True); + return Component_List_Node; + else + Error_Msg ("NULL component only allowed in null record", Null_Loc); + end if; + end if; - if Token = Tok_Comma or else Token = Tok_Colon then - Restore_Scan_State (Scan_State); - Scan_Reserved_Identifier (Force_Msg => True); + -- Scan components for non-null record - -- Note reserved identifier used as field name after - -- all because not followed by colon or comma + P_Pragmas_Opt (Decls_List); - else - Restore_Scan_State (Scan_State); - exit Component_Scan_Loop; - end if; + if Token /= Tok_Case then + Component_Scan_Loop : loop + P_Component_Items (Decls_List); + P_Pragmas_Opt (Decls_List); - -- Non-identifier that definitely was not reserved id + exit Component_Scan_Loop when Token = Tok_End + or else Token = Tok_Case + or else Token = Tok_When; + + -- We are done if we do not have an identifier. However, if we + -- have a misspelled reserved identifier that is in a column to + -- the right of the record definition, we will treat it as an + -- identifier. It turns out to be too dangerous in practice to + -- accept such a mis-spelled identifier which does not have this + -- additional clue that confirms the incorrect spelling. + + if Token /= Tok_Identifier then + if Start_Column > Scope.Table (Scope.Last).Ecol + and then Is_Reserved_Identifier + then + Save_Scan_State (Scan_State); -- at reserved id + Scan; -- possible reserved id + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + + -- Note reserved identifier used as field name after all + -- because not followed by colon or comma. else + Restore_Scan_State (Scan_State); exit Component_Scan_Loop; end if; + + -- Non-identifier that definitely was not reserved id + + else + exit Component_Scan_Loop; end if; - end loop Component_Scan_Loop; - end if; + end if; + end loop Component_Scan_Loop; + end if; - if Token = Tok_Case then - Set_Variant_Part (Component_List_Node, P_Variant_Part); + if Token = Tok_Case then + Set_Variant_Part (Component_List_Node, P_Variant_Part); - -- Check for junk after variant part + -- Check for junk after variant part - if Token = Tok_Identifier then - Save_Scan_State (Scan_State); - Scan; -- past identifier + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past identifier - if Token = Tok_Colon then - Restore_Scan_State (Scan_State); - Error_Msg_SC ("component may not follow variant part"); - Discard_Junk_Node (P_Component_List); + if Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("component may not follow variant part"); + Discard_Junk_Node (P_Component_List); - elsif Token = Tok_Case then - Restore_Scan_State (Scan_State); - Error_Msg_SC ("only one variant part allowed in a record"); - Discard_Junk_Node (P_Component_List); + elsif Token = Tok_Case then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("only one variant part allowed in a record"); + Discard_Junk_Node (P_Component_List); - else - Restore_Scan_State (Scan_State); - end if; + else + Restore_Scan_State (Scan_State); end if; end if; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a1107f86e63..5aa090446b6 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1505,8 +1505,8 @@ package body Sem_Ch12 is Check_Overloaded_Formal_Subprogram (Formal); end if; - -- If there is no corresponding actual, this may be case of - -- partial parameterization, or else the formal has a + -- If there is no corresponding actual, this may be case + -- of partial parameterization, or else the formal has a -- default or a box. if No (Match) and then Partial_Parameterization then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5ff296c9a52..6289f1c5778 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2999,7 +2999,7 @@ package body Sem_Ch3 is and then No (Corresponding_Generic_Association (Parent (Obj_Id))) then Error_Msg_N - ("constant cannot be volatile (SPARK RM 7.1.3(4))", Obj_Id); + ("constant cannot be volatile (SPARK RM 7.1.3(6))", Obj_Id); end if; else pragma Assert (Ekind (Obj_Id) = E_Variable); @@ -3016,7 +3016,7 @@ package body Sem_Ch3 is then Error_Msg_N ("non-volatile variable & cannot have volatile components " - & "(SPARK RM 7.1.3(6))", Obj_Id); + & "(SPARK RM 7.1.3(7))", Obj_Id); -- The declaration of a volatile object must appear at the library -- level. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index cab0aa3547b..52845b4e511 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1094,13 +1094,13 @@ package body Sem_Ch4 is -- indexed component and analyze as container indexing. if not Is_Overloadable (Nam_Ent) then - if Present ( - Find_Value_Of_Aspect - (Etype (Nam_Ent), Aspect_Constant_Indexing)) + if Present + (Find_Value_Of_Aspect + (Etype (Nam_Ent), Aspect_Constant_Indexing)) then Replace (N, Make_Indexed_Component (Sloc (N), - Prefix => Nam, + Prefix => Nam, Expressions => Parameter_Associations (N))); if Try_Container_Indexing (N, Nam, Expressions (N)) then @@ -1112,6 +1112,7 @@ package body Sem_Ch4 is else No_Interpretation; end if; + return; end if; end if; @@ -7065,7 +7066,6 @@ package body Sem_Ch4 is while Present (Disc) loop declare Elmt_Type : Entity_Id; - begin if Has_Implicit_Dereference (Disc) then Elmt_Type := Designated_Type (Etype (Disc)); @@ -7098,6 +7098,7 @@ package body Sem_Ch4 is Set_Etype (Indexing, Any_Type); while Present (It.Nam) loop Analyze_One_Call (Indexing, It.Nam, False, Success); + if Success then Set_Etype (Name (Indexing), It.Typ); Set_Entity (Name (Indexing), It.Nam); @@ -7122,6 +7123,7 @@ package body Sem_Ch4 is exit; end if; + Get_Next_Interp (I, It); end loop; end; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 491e97c6a58..d4ca288586f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1855,6 +1855,9 @@ package body Sem_Ch5 is else Set_Ekind (Def_Id, E_Loop_Parameter); + if Ada_Version < Ada_2012 then + Error_Msg_N ("container iterators are an Ada 2012 feature", N); + end if; -- OF present diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f21bacacdb1..2b24d507f81 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7966,12 +7966,6 @@ package body Sem_Prag is end if; end if; - -- All interfaced procedures need an external symbol created - -- for them since they are always referenced from another - -- object file. - - Set_Is_Public (Def_Id); - -- Verify that the subprogram does not have a completion -- through a renaming declaration. For other completions the -- pragma appears as a too late representation. @@ -9425,6 +9419,12 @@ package body Sem_Prag is else Set_Is_Imported (E); + -- For subprogram, set Import_Pragma field + + if Is_Subprogram (E) then + Set_Import_Pragma (E, N); + end if; + -- If the entity is an object that is not at the library level, -- then it is statically allocated. We do not worry about objects -- with address clauses in this context since they are not really diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fa365214ee1..461e251e2b3 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7540,7 +7540,6 @@ package body Sem_Res is Pref : Node_Id; begin - -- In ASIS mode, propagate the information about the indices back to -- to the original indexing node. The generalized indexing is either -- a function call, or a dereference of one. The actuals include the @@ -7550,9 +7549,9 @@ package body Sem_Res is Resolve (Indexing, Typ); Set_Etype (N, Etype (Indexing)); Set_Is_Overloaded (N, False); + Call := Indexing; - while Nkind_In (Call, - N_Explicit_Dereference, N_Selected_Component) + while Nkind_In (Call, N_Explicit_Dereference, N_Selected_Component) loop Call := Prefix (Call); end loop; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index e115e7ad707..9b1c270d057 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1278,13 +1278,13 @@ package Sinfo is -- ali file. -- Generalized_Indexing (Node4-Sem) - -- Generalized_Indexing is set in Indexed_Component nodes that are Ada 2012 - -- container indexing operations. The value of the attribute is a function - -- call (possibly dereferenced) that corresponds to the proper expansion - -- of the source indexing operation. Before expansion, the source node - -- is rewritten as the resolved generalized indexing. In ASIS mode, the - -- expansion does not take place, so that the source is preserved and - -- properly annotated with types. + -- Present in N_Indexed_Component nodes. Set for Indexed_Component nodes + -- that are Ada 2012 container indexing operations. The value of the + -- attribute is a function call (possibly dereferenced) that corresponds + -- to the proper expansion of the source indexing operation. Before + -- expansion, the source node is rewritten as the resolved generalized + -- indexing. In ASIS mode, the expansion does not take place, so that + -- the source is preserved and properly annotated with types. -- Generic_Parent (Node5-Sem) -- Generic_Parent is defined on declaration nodes that are instances. The @@ -8924,6 +8924,7 @@ package Sinfo is function Generalized_Indexing (N : Node_Id) return Node_Id; -- Node4 + function Generic_Associations (N : Node_Id) return List_Id; -- List3 @@ -10933,7 +10934,7 @@ package Sinfo is (1 => True, -- Expressions (List1) 2 => False, -- unused 3 => True, -- Prefix (Node3) - 4 => False, -- Generalized_Indexing (Node4-Sem) + 4 => False, -- Generalized_Indexing (Node4-Sem) 5 => False), -- Etype (Node5-Sem) N_Slice => |