Skip to content

R
riscv-gcc-1
Commit 473e20df by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r189773
parent 219d9cc7
Showing with 482 additions and 262 deletions
gcc/ada/ChangeLog
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
......
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;
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
......
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;
......
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
......
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;
......
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
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
......
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
......
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);
......
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;
......
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);
......
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);
......
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
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment