diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 72 | ||||
| -rw-r--r-- | gcc/ada/a-cfdlli.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/g-spitbo.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/g-spitbo.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 6 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 472 | ||||
| -rw-r--r-- | gcc/ada/par-ch6.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 25 |
15 files changed, 482 insertions, 262 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b24acecf69a..eda6cbb64ec 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,75 @@ +2012-07-23 Vincent Celier <celier@adacore.com> + + * g-spitbo.adb (Substr (String)): Return full string and do not + raise exception when Start is 1 and Len is exactly the length + of the string parameter. + * g-spitbo.ads: Fix spelling error in the name of exception + Index_Error. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * par.adb: new subprogram Get_Aspect_Specifications. + * par-ch6.adb (P_Subprogram): handle subprogram bodies with aspect + specifications. + * par-ch13.adb (Get_Aspect_Specifications): extracted from + P_Aspect_Specifications. Collect aspect specifications in some + legal context, but do not attach them to any declaration. Used + when parsing subprogram declarations or bodies that include + aspect specifications. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If aspects are + present, analyze them, or reject them if the subprogram as a + previous spec. + +2012-07-23 Vasiliy Fofanov <fofanov@adacore.com> + + * gnat_ugn.texi: Omit section on other platforms/runtimes support + in gnattest for vms version. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): + Handle properly aspects that can be specified on a subprogram + body: CPU, Priority, and Interrupt_Priority. + +2012-07-23 Claire Dross <dross@adacore.com> + + * a-cfdlli.ads: Switch definition of Constant_Reference_Type + and Empty_List. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb (Process_Decisions.Output_Header): For the guard + on an alternative in a SELECT statement, use the First_Sloc + of the guard expression (not its topmost sloc) as the decision + location, because this is what is referenced by dominance markers. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Requires_Hooking): Examine the original expression + of an object declaration node because a function call that + returns on the secondary stack may have been rewritten into + something else. + +2012-07-23 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Has_Etype): For identifier, propagate + dimension when entity is a non-dimensionless constant. + (Analyze_Dimension_Object_Declaration): Propagate + dimension from the expression to the entity when type is a + dimensioned type and object is a constant. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case 'Old): if the prefix + is not an entity name, expand at once so that code generated by + the expansion of the prefix is not generated before the constant + that captures the old value is properly inserted and analyzed. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb (Ensure_Statement_Present): Mark generated NULL + statement as Comes_From_Source so that GIGI does not eliminate it. + 2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch12.adb (Insert_Freeze_Node_For_Instance): Inst is now diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 8bf8a3d61a3..67ff3af8f48 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -307,6 +307,9 @@ private Node : Count_Type := 0; end record; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out Cursor); @@ -323,7 +326,4 @@ private No_Element : constant Cursor := (Node => 0); - type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; - end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 9be3a18bb17..6483c7e339d 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4369,12 +4369,16 @@ package body Exp_Ch7 is function Requires_Hooking return Boolean is begin -- The context is either a procedure or function call or an object - -- declaration initialized by a function call. In all these cases, - -- the calls might raise an exception. + -- declaration initialized by a function call. Note that in the + -- latter case, a function call that returns on the secondary + -- stack is usually rewritten into something else. Its proper + -- detection requires examination of the original initialization + -- expression. return Nkind (N) in N_Subprogram_Call - or else (Nkind (N) = N_Object_Declaration - and then Nkind (Expression (N)) = N_Function_Call); + or else (Nkind (N) = N_Object_Declaration + and then Nkind (Original_Node (Expression (N))) = + N_Function_Call); end Requires_Hooking; -- Local variables diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6f37b78522c..29306043dcb 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5484,11 +5484,19 @@ package body Exp_Ch9 is ------------------------------ procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is + Stmt : Node_Id; begin if Opt.Suppress_Control_Flow_Optimizations and then Is_Empty_List (Statements (Alt)) then - Set_Statements (Alt, New_List (Make_Null_Statement (Loc))); + Stmt := Make_Null_Statement (Loc); + + -- Mark NULL statement as coming from source so that it is not + -- eliminated by GIGI. + + Set_Comes_From_Source (Stmt, True); + + Set_Statements (Alt, New_List (Stmt)); end if; end Ensure_Statement_Present; diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb index 22677d72695..22677149ee1 100644 --- a/gcc/ada/g-spitbo.adb +++ b/gcc/ada/g-spitbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, AdaCore -- +-- Copyright (C) 1998-2012, AdaCore -- -- -- -- 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- -- @@ -305,7 +305,7 @@ package body GNAT.Spitbol is begin if Start > Str'Length then raise Index_Error; - elsif Start + Len > Str'Length then + elsif Start + Len - 1 > Str'Length then raise Length_Error; else return diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads index 94068f83af0..e97bb62d033 100644 --- a/gcc/ada/g-spitbo.ads +++ b/gcc/ada/g-spitbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2010, AdaCore -- +-- Copyright (C) 1997-2012, AdaCore -- -- -- -- 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- -- @@ -180,7 +180,7 @@ package GNAT.Spitbol is -- Returns the substring starting at the given character position (which -- is always counted from the start of the string, regardless of bounds, -- e.g. 2 means starting with the second character of the string), and - -- with the length (Len) given. Indexing_Error is raised if the starting + -- with the length (Len) given. Index_Error is raised if the starting -- position is out of range, and Length_Error is raised if Len is too long. function Trim (Str : VString) return VString; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 934db21f2c4..e440ed517ed 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -487,7 +487,9 @@ Creating Unit Tests Using gnattest * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +@ifclear vms * Support for other platforms/run-times:: +@end ifclear * Current Limitations:: Other Utility Programs @@ -18107,7 +18109,9 @@ is installed at its default location. * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +@ifclear vms * Support for other platforms/run-times:: +@end ifclear * Current Limitations:: @end menu @@ -18621,6 +18625,7 @@ gnatmake -Pmixing/test_driver.gpr mixing/test_runner @end smallexample +@ifclear vms @node Support for other platforms/run-times @section Support for other platforms/run-times @@ -18641,6 +18646,7 @@ the ZFP run-time library: @smallexample powerpc-elf-gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp @end smallexample +@end ifclear @node Current Limitations @section Current Limitations diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 8b2d3d469dd..2a257f5d7de 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -132,6 +132,251 @@ package body Ch13 is return Result; end Aspect_Specifications_Present; + ------------------------------- + -- Get_Aspect_Specifications -- + ------------------------------- + + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id + is + Aspects : List_Id; + Aspect : Node_Id; + A_Id : Aspect_Id; + OK : Boolean; + + begin + Aspects := Empty_List; + + -- Check if aspect specification present + + if not Aspect_Specifications_Present then + if Semicolon then + TF_Semicolon; + end if; + + return Aspects; + end if; + + Scan; -- past WITH + Aspects := Empty_List; + + loop + OK := True; + + if Token /= Tok_Identifier then + Error_Msg_SC ("aspect identifier expected"); + + if Semicolon then + Resync_Past_Semicolon; + end if; + + return Aspects; + end if; + + -- We have an identifier (which should be an aspect identifier) + + A_Id := Get_Aspect_Id (Token_Name); + Aspect := + Make_Aspect_Specification (Token_Ptr, + Identifier => Token_Node); + + -- No valid aspect identifier present + + if A_Id = No_Aspect then + Error_Msg_SC ("aspect identifier expected"); + + -- Check bad spelling + + for J in Aspect_Id loop + if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then + Error_Msg_Name_1 := Aspect_Names (J); + Error_Msg_SC -- CODEFIX + ("\possible misspelling of%"); + exit; + end if; + end loop; + + Scan; -- past incorrect identifier + + if Token = Tok_Apostrophe then + Scan; -- past ' + Scan; -- past presumably CLASS + end if; + + if Token = Tok_Arrow then + Scan; -- Past arrow + Set_Expression (Aspect, P_Expression); + OK := False; + + elsif Token = Tok_Comma then + OK := False; + + else + if Semicolon then + Resync_Past_Semicolon; + end if; + + return Aspects; + end if; + + -- OK aspect scanned + + else + Scan; -- past identifier + + -- Check for 'Class present + + if Token = Tok_Apostrophe then + if not Class_Aspect_OK (A_Id) then + Error_Msg_Node_1 := Identifier (Aspect); + Error_Msg_SC ("aspect& does not permit attribute here"); + Scan; -- past apostrophe + Scan; -- past presumed CLASS + OK := False; + + else + Scan; -- past apostrophe + + if Token /= Tok_Identifier + or else Token_Name /= Name_Class + then + Error_Msg_SC ("Class attribute expected here"); + OK := False; + + if Token = Tok_Identifier then + Scan; -- past identifier not CLASS + end if; + + else + Scan; -- past CLASS + Set_Class_Present (Aspect); + end if; + end if; + end if; + + -- Test case of missing aspect definition + + if Token = Tok_Comma + or else Token = Tok_Semicolon + then + if Aspect_Argument (A_Id) /= Optional then + Error_Msg_Node_1 := Identifier (Aspect); + Error_Msg_AP ("aspect& requires an aspect definition"); + OK := False; + end if; + + elsif not Semicolon and then Token /= Tok_Arrow then + if Aspect_Argument (A_Id) /= Optional then + + -- The name or expression may be there, but the arrow is + -- missing. Skip to the end of the declaration. + + T_Arrow; + Resync_To_Semicolon; + end if; + + -- Here we have an aspect definition + + else + if Token = Tok_Arrow then + Scan; -- past arrow + else + T_Arrow; + OK := False; + end if; + + if Aspect_Argument (A_Id) = Name then + Set_Expression (Aspect, P_Name); + else + Set_Expression (Aspect, P_Expression); + end if; + end if; + + -- If OK clause scanned, add it to the list + + if OK then + Append (Aspect, Aspects); + end if; + + if Token = Tok_Comma then + Scan; -- past comma + goto Continue; + + -- Recognize the case where a comma is missing between two + -- aspects, issue an error and proceed with next aspect. + + elsif Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_AP -- CODEFIX + ("|missing "","""); + goto Continue; + + else + Restore_Scan_State (Scan_State); + end if; + end; + + -- Recognize the case where a semicolon was mistyped for a comma + -- between two aspects, issue an error and proceed with next + -- aspect. + + elsif Token = Tok_Semicolon then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + if Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + Scan; -- past identifier + + if Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); + Scan; -- past semicolon + goto Continue; + + else + Restore_Scan_State (Scan_State); + end if; + + else + Restore_Scan_State (Scan_State); + end if; + end; + end if; + + -- Must be terminator character + + if Semicolon then + T_Semicolon; + end if; + + exit; + + <<Continue>> + null; + end if; + end loop; + + return Aspects; + + end Get_Aspect_Specifications; + -------------------------------------------- -- 13.1 Representation Clause (also I.7) -- -------------------------------------------- @@ -397,244 +642,19 @@ package body Ch13 is Semicolon : Boolean := True) is Aspects : List_Id; - Aspect : Node_Id; - A_Id : Aspect_Id; - OK : Boolean; Ptr : Source_Ptr; begin - -- Check if aspect specification present - - if not Aspect_Specifications_Present then - if Semicolon then - TF_Semicolon; - end if; - - return; - end if; -- Aspect Specification is present Ptr := Token_Ptr; - Scan; -- past WITH -- Here we have an aspect specification to scan, note that we don't -- set the flag till later, because it may turn out that we have no -- valid aspects in the list. - Aspects := Empty_List; - loop - OK := True; - - if Token /= Tok_Identifier then - Error_Msg_SC ("aspect identifier expected"); - - if Semicolon then - Resync_Past_Semicolon; - end if; - - return; - end if; - - -- We have an identifier (which should be an aspect identifier) - - A_Id := Get_Aspect_Id (Token_Name); - Aspect := - Make_Aspect_Specification (Token_Ptr, - Identifier => Token_Node); - - -- No valid aspect identifier present - - if A_Id = No_Aspect then - Error_Msg_SC ("aspect identifier expected"); - - -- Check bad spelling - - for J in Aspect_Id loop - if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then - Error_Msg_Name_1 := Aspect_Names (J); - Error_Msg_SC -- CODEFIX - ("\possible misspelling of%"); - exit; - end if; - end loop; - - Scan; -- past incorrect identifier - - if Token = Tok_Apostrophe then - Scan; -- past ' - Scan; -- past presumably CLASS - end if; - - if Token = Tok_Arrow then - Scan; -- Past arrow - Set_Expression (Aspect, P_Expression); - OK := False; - - elsif Token = Tok_Comma then - OK := False; - - else - if Semicolon then - Resync_Past_Semicolon; - end if; - - return; - end if; - - -- OK aspect scanned - - else - Scan; -- past identifier - - -- Check for 'Class present - - if Token = Tok_Apostrophe then - if not Class_Aspect_OK (A_Id) then - Error_Msg_Node_1 := Identifier (Aspect); - Error_Msg_SC ("aspect& does not permit attribute here"); - Scan; -- past apostrophe - Scan; -- past presumed CLASS - OK := False; - - else - Scan; -- past apostrophe - - if Token /= Tok_Identifier - or else Token_Name /= Name_Class - then - Error_Msg_SC ("Class attribute expected here"); - OK := False; - - if Token = Tok_Identifier then - Scan; -- past identifier not CLASS - end if; - - else - Scan; -- past CLASS - Set_Class_Present (Aspect); - end if; - end if; - end if; - - -- Test case of missing aspect definition - - if Token = Tok_Comma - or else Token = Tok_Semicolon - then - if Aspect_Argument (A_Id) /= Optional then - Error_Msg_Node_1 := Identifier (Aspect); - Error_Msg_AP ("aspect& requires an aspect definition"); - OK := False; - end if; - - elsif not Semicolon and then Token /= Tok_Arrow then - if Aspect_Argument (A_Id) /= Optional then - - -- The name or expression may be there, but the arrow is - -- missing. Skip to the end of the declaration. - - T_Arrow; - Resync_To_Semicolon; - end if; - - -- Here we have an aspect definition - - else - if Token = Tok_Arrow then - Scan; -- past arrow - else - T_Arrow; - OK := False; - end if; - - if Aspect_Argument (A_Id) = Name then - Set_Expression (Aspect, P_Name); - else - Set_Expression (Aspect, P_Expression); - end if; - end if; - - -- If OK clause scanned, add it to the list - - if OK then - Append (Aspect, Aspects); - end if; - - if Token = Tok_Comma then - Scan; -- past comma - goto Continue; - - -- Recognize the case where a comma is missing between two - -- aspects, issue an error and proceed with next aspect. - - elsif Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - declare - Scan_State : Saved_Scan_State; - - begin - Save_Scan_State (Scan_State); - Scan; -- past identifier - - if Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_AP -- CODEFIX - ("|missing "","""); - goto Continue; - - else - Restore_Scan_State (Scan_State); - end if; - end; - - -- Recognize the case where a semicolon was mistyped for a comma - -- between two aspects, issue an error and proceed with next - -- aspect. - - elsif Token = Tok_Semicolon then - declare - Scan_State : Saved_Scan_State; - - begin - Save_Scan_State (Scan_State); - Scan; -- past semicolon - - if Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - Scan; -- past identifier - - if Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_SC -- CODEFIX - ("|"";"" should be "","""); - Scan; -- past semicolon - goto Continue; - - else - Restore_Scan_State (Scan_State); - end if; - - else - Restore_Scan_State (Scan_State); - end if; - end; - end if; - - -- Must be terminator character - - if Semicolon then - T_Semicolon; - end if; - - exit; - - <<Continue>> - null; - end if; - end loop; + Aspects := Get_Aspect_Specifications (Semicolon); -- Here if aspects present diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index f527dbe81cb..a05e79b51d6 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -154,6 +154,7 @@ package body Ch6 is function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is Specification_Node : Node_Id; Name_Node : Node_Id; + Aspects : List_Id; Fpart_List : List_Id; Fpart_Sloc : Source_Ptr; Result_Not_Null : Boolean := False; @@ -186,6 +187,8 @@ package body Ch6 is Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; + Aspects := Empty_List; + -- Ada 2005: Scan leading NOT OVERRIDING indicator if Token = Tok_Not then @@ -810,6 +813,16 @@ package body Ch6 is New_Node (N_Subprogram_Body, Sloc (Specification_Node)); Set_Specification (Body_Node, Specification_Node); + -- If aspects are present, the specification is parsed as + -- a subprogram declaration, and we jump here after seeing + -- the keyword IS. Attach asspects previously collected to + -- the body. + + if Is_Non_Empty_List (Aspects) then + Set_Parent (Aspects, Body_Node); + Set_Aspect_Specifications (Body_Node, Aspects); + end if; + -- In SPARK, a HIDE directive can be placed at the beginning -- of a subprogram implementation, thus hiding the -- subprogram body from SPARK tool-set. No violation of the @@ -841,7 +854,24 @@ package body Ch6 is Decl_Node := New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); Set_Specification (Decl_Node, Specification_Node); - P_Aspect_Specifications (Decl_Node); + Aspects := Get_Aspect_Specifications (Semicolon => False); + + -- Aspects may be present on a subprogram body. The source parsed + -- so far is that of its specification, go parse the body and attach + -- the collected aspects, if any, to the body. + + if Token = Tok_Is then + Scan; + goto Subprogram_Body; + + else + if Is_Non_Empty_List (Aspects) then + Set_Parent (Aspects, Decl_Node); + Set_Aspect_Specifications (Decl_Node, Aspects); + end if; + + TF_Semicolon; + end if; -- If this is a context in which a subprogram body is permitted, -- set active SIS entry in case (see section titled "Handling diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 3f9d541ef7f..892aac86bfd 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -876,6 +876,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- for aspects so it does not matter whether the aspect specifications -- are terminated by semicolon or some other character. + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id; + -- Parse a list of aspects but do not attach them to a declaration node. + -- Subsidiary to the following procedure. Used when parsing a subprogram + -- specification that may be a declaration or a body. + procedure P_Aspect_Specifications (Decl : Node_Id; Semicolon : Boolean := True); diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 766621ada52..fd1d887284f 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Debug; use Debug; +with Errout; use Errout; with Lib; use Lib; with Lib.Util; use Lib.Util; with Namet; use Namet; @@ -495,13 +496,15 @@ package body Par_SCO is -- levels (through the pragma argument association) to get to -- the pragma node itself. For the guard on a select -- alternative, we do not have access to the token location - -- for the WHEN, so we use the sloc of the condition itself. + -- for the WHEN, so we use the first sloc of the condition + -- itself (note: we use First_Sloc, not Sloc, because this is + -- what is referenced by dominance markers). if Nkind_In (Parent (N), N_Accept_Alternative, N_Delay_Alternative, N_Terminate_Alternative) then - Loc := Sloc (N); + Loc := First_Sloc (N); else Loc := Sloc (Parent (Parent (N))); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af1a8172ec4..e1abe5a048d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4026,14 +4026,15 @@ package body Sem_Attr is -- an entity in the enclosing subprogram. If it is a component of -- a formal its expansion might generate actual subtypes that may -- be referenced in an inner context, and which must be elaborated - -- within the subprogram itself. As a result we create a - -- declaration for it and insert it at the start of the enclosing - -- subprogram. This is properly an expansion activity but it has - -- to be performed now to prevent out-of-order issues. - - if Nkind (P) = N_Selected_Component - and then Has_Discriminants (Etype (Prefix (P))) - then + -- within the subprogram itself. If the prefix includes a function + -- call it may involve finalization actions that should only be + -- inserted when the attribute has been rewritten as a declarations. + -- As a result, if the prefix is not a simple name we create a + -- declaration for it now, and insert it at the start of the + -- enclosing subprogram. This is properly an expansion activity but + -- it has to be performed now to prevent out-of-order issues. + + if not Is_Entity_Name (P) then P_Type := Base_Type (P_Type); Set_Etype (N, P_Type); Set_Etype (P, P_Type); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d68eeaffe86..df61549e137 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1150,17 +1150,14 @@ package body Sem_Ch13 is Aspect_Bit_Order | Aspect_Component_Size | Aspect_Constant_Indexing | - Aspect_CPU | Aspect_Default_Iterator | Aspect_Dispatching_Domain | Aspect_External_Tag | Aspect_Input | - Aspect_Interrupt_Priority | Aspect_Iterator_Element | Aspect_Machine_Radix | Aspect_Object_Size | Aspect_Output | - Aspect_Priority | Aspect_Read | Aspect_Scalar_Storage_Order | Aspect_Size | @@ -1341,6 +1338,29 @@ package body Sem_Ch13 is Make_Identifier (Loc, P_Name)); end; + -- The following three aspects can be specified for a + -- subprogram body, in which case we generate pragmas for them + -- and insert them ahead of local declarations, rather than + -- after the body. + + when Aspect_CPU | + Aspect_Interrupt_Priority | + Aspect_Priority => + if Nkind (N) = N_Subprogram_Body then + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Relocate_Node (Expr)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + else + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + end if; + when Aspect_Warnings => -- Construct the pragma @@ -1725,7 +1745,8 @@ package body Sem_Ch13 is -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the - -- N_Compilation_Unit_Aux node. No delay is required here. + -- N_Compilation_Unit_Aux node (No delay is required here) + -- except for aspects on a subprogram body (see below). if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) @@ -1757,11 +1778,25 @@ package body Sem_Ch13 is end if; end if; - if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, Empty_List); + -- If the aspect is on a subprogram body (relevant aspects + -- are Inline and Priority), add the pragma in front of + -- the declarations. + + if Nkind (N) = N_Subprogram_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + Prepend (Aitem, Declarations (N)); + + else + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, Empty_List); + end if; + + Append (Aitem, Pragmas_After (Aux)); end if; - Append (Aitem, Pragmas_After (Aux)); goto Continue; end; end if; @@ -3243,10 +3278,11 @@ package body Sem_Ch13 is if From_Aspect_Specification (N) then if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent)) + or else Is_Task_Type (U_Ent) + or else Ekind (U_Ent) = E_Procedure) then Error_Msg_N - ("Priority can only be defined for task and protected" & + ("Priority can only be defined for task and protected " & "object", Nam); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b568ebbc949..5f061616ee3 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2504,6 +2504,19 @@ package body Sem_Ch6 is end if; end if; + -- Ada 2012 aspects may appear in a subprogram body, but only if there + -- is no previous spec. + + if Has_Aspects (N) then + if Present (Corresponding_Spec (N)) then + Error_Msg_N + ("aspect specifications must appear in subprogram declaration", + N); + else + Analyze_Aspect_Specifications (N, Body_Id); + end if; + end if; + -- Previously we scanned the body to look for nested subprograms, and -- rejected an inline directive if nested subprograms were present, -- because the back-end would generate conflicting symbols for the diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 1d0307cf330..3d0e1dd348d 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1617,6 +1617,14 @@ package body Sem_Dim is if Exists (Dims_Of_Etyp) then Set_Dimensions (N, Dims_Of_Etyp); + + -- Propagation of the dimensions from the entity for identifier whose + -- entity is a non-dimensionless consant. + + elsif Nkind (N) = N_Identifier + and then Exists (Dimensions_Of (Entity (N))) + then + Set_Dimensions (N, Dimensions_Of (Entity (N))); end if; -- Removal of dimensions in expression @@ -1692,7 +1700,7 @@ package body Sem_Dim is if Present (Expr) then Dim_Of_Expr := Dimensions_Of (Expr); - -- case when expression is not a literal and when dimensions of the + -- Case when expression is not a literal and when dimensions of the -- expression and of the type mismatch if not Nkind_In (Original_Node (Expr), @@ -1700,7 +1708,20 @@ package body Sem_Dim is N_Integer_Literal) and then Dim_Of_Expr /= Dim_Of_Etyp then - Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); + -- Propagate the dimension from the expression to the object + -- entity when the object is a constant whose type is a + -- dimensioned type. + + if Constant_Present (N) + and then not Exists (Dim_Of_Etyp) + then + Set_Dimensions (Id, Dim_Of_Expr); + + -- Otherwise, issue an error message + + else + Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); + end if; end if; -- Removal of dimensions in expression |
