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
+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
-- --
-- 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 --
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);
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;
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
------------------------------
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;
-- --
-- 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- --
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
-- --
-- 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- --
-- 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;
* Tagged Types Substitutability Testing::
* Testing with Contracts::
* Additional Tests::
+@ifclear vms
* Support for other platforms/run-times::
+@end ifclear
* Current Limitations::
Other Utility Programs
* Tagged Types Substitutability Testing::
* Testing with Contracts::
* Additional Tests::
+@ifclear vms
* Support for other platforms/run-times::
+@end ifclear
* Current Limitations::
@end menu
mixing/test_runner
@end smallexample
+@ifclear vms
@node Support for other platforms/run-times
@section Support for other platforms/run-times
@smallexample
powerpc-elf-gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp
@end smallexample
+@end ifclear
@node Current Limitations
@section Current Limitations
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) --
--------------------------------------------
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
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;
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
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
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
-- --
-- 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- --
-- 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);
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;
-- 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;
-- 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);
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 |
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
-- 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))
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;
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);
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
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
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),
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
projects / thirdparty / gcc.git / commitdiff
