+2013-09-10 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * aspects.adb: Add entries in the Has_Aspect_Specifications_Flag
+ table for package body and body stubs.
+ (Move_Or_Merge_Aspects): New routine.
+ (Remove_Aspects): New routine.
+ * aspects.ads (Move_Aspects): Update comment on usage.
+ (Move_Or_Merge_Aspects): New routine.
+ (Remove_Aspects): New routine.
+ * par-ch3.adb: Update the grammar of private_type_declaration,
+ private_extension_declaration, object_renaming_declaration,
+ and exception_renaming_declaration.
+ (P_Subprogram): Parse the
+ aspect specifications that apply to a body stub.
+ * par-ch6.adb: Update the grammar of subprogram_body_stub and
+ generic_instantiation.
+ * par-ch7.adb: Update the grammar of package_declaration,
+ package_specification, package_body, package_renaming_declaration,
+ package_body_stub.
+ (P_Package): Parse the aspect specifications
+ that apply to a body, a body stub and package renaming.
+ * par-ch9.adb: Update the grammar of entry_declaration,
+ protected_body, protected_body_stub, task_body,
+ and task_body_stub.
+ (P_Protected): Add local variable
+ Aspect_Sloc. Add local constant Dummy_Node. Parse the aspect
+ specifications that apply to a protected body and a protected
+ body stub.
+ (P_Task): Add local variable Aspect_Sloc. Add local
+ constant Dummy_Node. Parse the aspect specifications that apply
+ to a task body and a task body stub.
+ * par-ch12.adb: Update the grammar of
+ generic_renaming_declaration.
+ (P_Generic): Parse the aspect
+ specifications that apply to a generic renaming.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not emit
+ an error when analyzing aspects that apply to a body stub. Such
+ aspects are relocated to the proper body.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Analyze the aspect
+ specifications that apply to a body.
+ * sem_ch9.adb (Analyze_Protected_Body): Warn about user-defined
+ aspects not being supported on protected bodies. Remove the
+ aspect specifications. (Analyze_Single_Protected_Declaration):
+ Analyze the aspects that apply to a single protected declaration.
+ (Analyze_Task_Body): Warn about user-defined aspects not being
+ supported on task bodies. Remove the aspect specifications.
+ * sem_ch10.adb: Add with and use clause for Aspects.
+ (Analyze_Package_Body_Stub): Propagate the aspect specifications
+ from the stub to the proper body.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Insert the
+ corresponding pragma of an aspect that applies to a body in the
+ declarations of the body.
+ * sinfo.ads: Update the gramma of expression_function,
+ private_type_declaration, private_extension_declaration,
+ object_renaming_declaration, exception_renaming_declaration,
+ package_renaming_declaration, subprogram_renaming_declaration,
+ generic_renaming_declaration, entry_declaration,
+ subprogram_body_stub, package_body_stub, task_body_stub,
+ generic_subprogram_declaration.
+
+2013-09-10 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Add processing
+ for aspect/pragma SPARK_Mode when it applies to a [library-level]
+ subprogram or package [body].
+
+2013-09-10 Robert Dewar <dewar@adacore.com>
+
+ * gnat_ugn.texi: Document that -gnatc and -gnatR cannot be
+ given together.
+ * switch-c.adb (Scan_Front_End_Switches): Give error if both
+ -gnatR and -gnatc given.
+
+2013-09-10 Robert Dewar <dewar@adacore.com>
+
+ * g-table.ads, g-table.adb (For_Each): New generic procedure
+ (Sort_Table): New generic procedure.
+
2013-09-10 Thomas Quinot <quinot@adacore.com>
* adaint.c (__gnat_is_executable_file_attr): Should be true
end if;
end Move_Aspects;
+ ---------------------------
+ -- Move_Or_Merge_Aspects --
+ ---------------------------
+
+ procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is
+ begin
+ if Has_Aspects (From) then
+
+ -- Merge the aspects of From into To. Make sure that From has no
+ -- aspects after the merge takes place.
+
+ if Has_Aspects (To) then
+ Append_List
+ (List => Aspect_Specifications (From),
+ To => Aspect_Specifications (To));
+ Remove_Aspects (From);
+
+ -- Otherwise simply move the aspects
+
+ else
+ Move_Aspects (From => From, To => To);
+ end if;
+ end if;
+ end Move_Or_Merge_Aspects;
+
-----------------------------------
-- Permits_Aspect_Specifications --
-----------------------------------
N_Generic_Subprogram_Declaration => True,
N_Object_Declaration => True,
N_Object_Renaming_Declaration => True,
+ N_Package_Body => True,
+ N_Package_Body_Stub => True,
N_Package_Declaration => True,
N_Package_Instantiation => True,
N_Package_Specification => True,
N_Private_Type_Declaration => True,
N_Procedure_Instantiation => True,
N_Protected_Body => True,
+ N_Protected_Body_Stub => True,
N_Protected_Type_Declaration => True,
N_Single_Protected_Declaration => True,
N_Single_Task_Declaration => True,
N_Subprogram_Body_Stub => True,
N_Subtype_Declaration => True,
N_Task_Body => True,
+ N_Task_Body_Stub => True,
N_Task_Type_Declaration => True,
others => False);
return Has_Aspect_Specifications_Flag (Nkind (N));
end Permits_Aspect_Specifications;
+ --------------------
+ -- Remove_Aspects --
+ --------------------
+
+ procedure Remove_Aspects (N : Node_Id) is
+ begin
+ if Has_Aspects (N) then
+ Aspect_Specifications_Hash_Table.Remove (N);
+ Set_Has_Aspects (N, False);
+ end if;
+ end Remove_Aspects;
+
-----------------
-- Same_Aspect --
-----------------
-- Determine whether entity Id has aspect A
procedure Move_Aspects (From : Node_Id; To : Node_Id);
- -- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be
- -- False on entry. If Has_Aspects (From) is False, the call has no effect.
- -- Otherwise the aspects are moved and on return Has_Aspects (To) is True,
- -- and Has_Aspects (From) is False.
+ -- Relocate the aspect specifications of node From to node To. On entry it
+ -- is assumed that To does not have aspect specifications. If From has no
+ -- aspects, the routine has no effect.
+
+ procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id);
+ -- Relocate the aspect specifications of node From to node To. If To has
+ -- aspects, the aspects of From are added to the aspects of To. If From has
+ -- no aspects, the routine has no effect.
function Permits_Aspect_Specifications (N : Node_Id) return Boolean;
-- Returns True if the node N is a declaration node that permits aspect
-- specifications in the grammar. It is possible for other nodes to have
-- aspect specifications as a result of Rewrite or Replace calls.
+ procedure Remove_Aspects (N : Node_Id);
+ -- Delete the aspect specifications associated with node N. If the node has
+ -- no aspects, the routine has no effect.
+
function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean;
-- Returns True if A1 and A2 are (essentially) the same aspect. This is not
-- a simple equality test because e.g. Post and Postcondition are the same.
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2010, AdaCore --
+-- Copyright (C) 1998-2013, 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- --
-- --
------------------------------------------------------------------------------
+with GNAT.Heap_Sort_G;
+
with System; use System;
with System.Memory; use System.Memory;
Last_Val := Last_Val - 1;
end Decrement_Last;
+ --------------
+ -- For_Each --
+ --------------
+
+ procedure For_Each is
+ Quit : Boolean := False;
+ begin
+ for Index in Table_Low_Bound .. Table_Index_Type (Last_Val) loop
+ Action (Index, Table (Index), Quit);
+ exit when Quit;
+ end loop;
+ end For_Each;
+
----------
-- Free --
----------
pragma Import (Ada, Allocated_Table);
pragma Suppress (Range_Check, On => Allocated_Table);
for Allocated_Table'Address use Allocated_Table_Address;
- -- Allocated_Table represents the currently allocated array, plus
- -- one element (the supplementary element is used to have a
- -- convenient way of computing the address just past the end of the
- -- current allocation). Range checks are suppressed because this unit
- -- uses direct calls to System.Memory for allocation, and this can
- -- yield misaligned storage (and we cannot rely on the bootstrap
- -- compiler supporting specifically disabling alignment checks, so we
- -- need to suppress all range checks). It is safe to suppress this check
- -- here because we know that a (possibly misaligned) object of that type
- -- does actually exist at that address.
- -- ??? We should really improve the allocation circuitry here to
+ -- Allocated_Table represents the currently allocated array, plus one
+ -- element (the supplementary element is used to have a convenient
+ -- way of computing the address just past the end of the current
+ -- allocation). Range checks are suppressed because this unit uses
+ -- direct calls to System.Memory for allocation, and this can yield
+ -- misaligned storage (and we cannot rely on the bootstrap compiler
+ -- supporting specifically disabling alignment checks, so we need to
+ -- suppress all range checks). It is safe to suppress this check here
+ -- because we know that a (possibly misaligned) object of that type
+ -- does actually exist at that address. ??? We should really improve
+ -- the allocation circuitry here to
-- guarantee proper alignment.
Need_Realloc : constant Boolean := Integer (Index) > Max;
end if;
end Set_Last;
+ ----------------
+ -- Sort_Table --
+ ----------------
+
+ procedure Sort_Table is
+
+ Temp : Table_Component_Type;
+ -- A temporary position to simulate index 0
+
+ -- Local subprograms
+
+ function Index_Of (Idx : Natural) return Table_Index_Type;
+ -- Return index of Idx'th element of table
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean;
+ -- Compare two components
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move one component
+
+ package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
+
+ --------------
+ -- Index_Of --
+ --------------
+
+ function Index_Of (Idx : Natural) return Table_Index_Type is
+ J : constant Integer'Base := Table_Index_Type'Pos (First) + Idx - 1;
+ begin
+ return Table_Index_Type'Val (J);
+ end Index_Of;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ if From = 0 then
+ Table (Index_Of (To)) := Temp;
+ elsif To = 0 then
+ Temp := Table (Index_Of (From));
+ else
+ Table (Index_Of (To)) := Table (Index_Of (From));
+ end if;
+ end Move;
+
+ ----------------
+ -- Lower_Than --
+ ----------------
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Lt (Temp, Table (Index_Of (Op2)));
+ elsif Op2 = 0 then
+ return Lt (Table (Index_Of (Op1)), Temp);
+ else
+ return Lt (Table (Index_Of (Op1)), Table (Index_Of (Op2)));
+ end if;
+ end Lower_Than;
+
+ -- Start of processing for Sort_Table
+
+ begin
+ Heap_Sort.Sort (Natural (Last - First) + 1);
+ end Sort_Table;
+
begin
Init;
end GNAT.Table;
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2010, AdaCore --
+-- Copyright (C) 1998-2013, 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- --
-- This means that a reference X.Table (X.Allocate) is incorrect, since
-- the call to X.Allocate may modify the results of calling X.Table.
+ generic
+ with procedure Action
+ (Index : Table_Index_Type;
+ Item : Table_Component_Type;
+ Quit : in out Boolean) is <>;
+ procedure For_Each;
+ -- Calls procedure Action for each component of the table, or until
+ -- one of these calls set Quit to True.
+
+ generic
+ with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
+ procedure Sort_Table;
+ -- This procedure sorts the components of the table into ascending
+ -- order making calls to Lt to do required comparisons, and using
+ -- assignments to move components around. The Lt function returns True
+ -- if Comp1 is less than Comp2 (in the sense of the desired sort), and
+ -- False if Comp1 is greater than Comp2. For equal objects it does not
+ -- matter if True or False is returned (it is slightly more efficient
+ -- to return False). The sort is not stable (the order of equal items
+ -- in the table is not preserved).
+
end GNAT.Table;
@option{-gnatc} as a builder switch (before @option{-cargs} or in package
Builder of the project file) then @command{gnatmake} will not fail because
it will not look for the object files after compilation, and it will not try
-to build and link.
+to build and link. This switch may not be given if a previous @code{-gnatR}
+switch has been given, since @code{-gnatR} requires that the code generator
+be called to complete determination of representation information.
@item -gnatC
@cindex @option{-gnatC} (@command{gcc})
@item ^-gnatR@r{[}0@r{/}1@r{/}2@r{/}3@r{[}s@r{]]}^/REPRESENTATION_INFO^
@cindex @option{-gnatR} (@command{gcc})
Output representation information for declared types and objects.
-Note that this switch is not allowed if a previous
--gnatD switch has been given, since these two switches are not compatible.
+Note that this switch is not allowed if a previous @code{-gnatD} switch has
+been given, since these two switches are not compatible. It is also not allowed
+if a previous @code{-gnatc} switch has been given, since we must be generating
+code to be able to determine representation information.
@item -gnats
@cindex @option{-gnats} (@command{gcc})
-- GENERIC_RENAMING_DECLARATION ::=
-- generic package DEFINING_PROGRAM_UNIT_NAME
-- renames generic_package_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | generic procedure DEFINING_PROGRAM_UNIT_NAME
-- renames generic_procedure_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | generic function DEFINING_PROGRAM_UNIT_NAME
-- renames generic_function_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- GENERIC_FORMAL_PARAMETER_DECLARATION ::=
-- FORMAL_OBJECT_DECLARATION
Scan; -- past RENAMES
Set_Defining_Unit_Name (Decl_Node, Def_Unit);
Set_Name (Decl_Node, P_Name);
+
+ P_Aspect_Specifications (Decl_Node, Semicolon => False);
TF_Semicolon;
return Decl_Node;
end if;
else
Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
-
Set_Specification (Gen_Decl, P_Subprogram_Specification);
if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) =
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
- -- is [abstract] [tagged] [limited] private;
+ -- is [abstract] [tagged] [limited] private
+ -- [ASPECT_SPECIFICATIONS];
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] [limited | synchronized]
-- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
- -- with private;
+ -- with private [ASPECT_SPECIFICATIONS];
-- TYPE_DEFINITION ::=
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER :
- -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER :
- -- ACCESS_DEFINITION renames object_NAME;
+ -- ACCESS_DEFINITION renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- EXCEPTION_RENAMING_DECLARATION ::=
- -- DEFINING_IDENTIFIER : exception renames exception_NAME;
+ -- DEFINING_IDENTIFIER : exception renames exception_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- EXCEPTION_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : exception
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- ACCESS_DEFINITION [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER :
- -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER :
- -- ACCESS_DEFINITION renames object_NAME;
+ -- ACCESS_DEFINITION renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] [limited | synchronized]
-- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
- -- with private;
+ -- with private [ASPECT_SPECIFICATIONS];
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
-- [ASPECT_SPECIFICATIONS];
-- SUBPROGRAM_BODY_STUB ::=
- -- SUBPROGRAM_SPECIFICATION is separate;
+ -- SUBPROGRAM_SPECIFICATION is separate
+ -- [ASPECT_SPECIFICATIONS];
-- GENERIC_INSTANTIATION ::=
-- procedure DEFINING_PROGRAM_UNIT_NAME is
- -- new generic_procedure_NAME [GENERIC_ACTUAL_PART];
+ -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]
+ -- [ASPECT_SPECIFICATIONS];
-- | function DEFINING_DESIGNATOR is
- -- new generic_function_NAME [GENERIC_ACTUAL_PART];
+ -- new generic_function_NAME [GENERIC_ACTUAL_PART]
+ -- [ASPECT_SPECIFICATIONS];
-- NULL_PROCEDURE_DECLARATION ::=
-- SUBPROGRAM_SPECIFICATION is null;
if Token = Tok_Identifier
and then not Token_Is_At_Start_Of_Line
then
- T_Left_Paren; -- to generate message
- Fpart_List := P_Formal_Part;
+ T_Left_Paren; -- to generate message
+ Fpart_List := P_Formal_Part;
-- Otherwise scan out an optional formal part in the usual manner
Sloc (Name_Node));
end if;
+ Scan; -- past SEPARATE
+
Stub_Node :=
New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
Set_Specification (Stub_Node, Specification_Node);
- -- The specification has been parsed as part of a subprogram
- -- declaration, and aspects have already been collected.
-
if Is_Non_Empty_List (Aspects) then
- Set_Parent (Aspects, Stub_Node);
- Set_Aspect_Specifications (Stub_Node, Aspects);
+ Error_Msg
+ ("aspect specifications must come after SEPARATE",
+ Sloc (First (Aspects)));
end if;
- Scan; -- past SEPARATE
- Pop_Scope_Stack;
+ P_Aspect_Specifications (Stub_Node, Semicolon => False);
TF_Semicolon;
+ Pop_Scope_Stack;
return Stub_Node;
-- Subprogram body or expression function case
-- renaming declaration or generic instantiation starting with PACKAGE
-- PACKAGE_DECLARATION ::=
- -- PACKAGE_SPECIFICATION
- -- [ASPECT_SPECIFICATIONS];
+ -- PACKAGE_SPECIFICATION;
-- PACKAGE_SPECIFICATION ::=
- -- package DEFINING_PROGRAM_UNIT_NAME is
+ -- package DEFINING_PROGRAM_UNIT_NAME
+ -- [ASPECT_SPECIFICATIONS]
+ -- is
-- {BASIC_DECLARATIVE_ITEM}
-- [private
-- {BASIC_DECLARATIVE_ITEM}]
-- end [[PARENT_UNIT_NAME .] IDENTIFIER]
-- PACKAGE_BODY ::=
- -- package body DEFINING_PROGRAM_UNIT_NAME is
+ -- package body DEFINING_PROGRAM_UNIT_NAME
+ -- [ASPECT_SPECIFICATIONS]
+ -- is
-- DECLARATIVE_PART
-- [begin
-- HANDLED_SEQUENCE_OF_STATEMENTS]
-- end [[PARENT_UNIT_NAME .] IDENTIFIER]
-- PACKAGE_RENAMING_DECLARATION ::=
- -- package DEFINING_IDENTIFIER renames package_NAME;
+ -- package DEFINING_IDENTIFIER renames package_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- PACKAGE_BODY_STUB ::=
- -- package body DEFINING_IDENTIFIER is separate;
+ -- package body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATIONS];
-- PACKAGE_INSTANTIATION ::=
-- package DEFINING_PROGRAM_UNIT_NAME is
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Name_Node := P_Defining_Program_Unit_Name;
Scope.Table (Scope.Last).Labl := Name_Node;
+
+ if Aspect_Specifications_Present then
+ Aspect_Sloc := Token_Ptr;
+ P_Aspect_Specifications (Dummy_Node, Semicolon => False);
+ end if;
+
TF_Is;
if Separate_Present then
end if;
Scan; -- past SEPARATE
- TF_Semicolon;
- Pop_Scope_Stack;
Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
Set_Defining_Identifier (Package_Node, Name_Node);
+ if Has_Aspects (Dummy_Node) then
+ Error_Msg
+ ("aspect specifications must come after SEPARATE",
+ Aspect_Sloc);
+ end if;
+
+ P_Aspect_Specifications (Package_Node, Semicolon => False);
+ TF_Semicolon;
+ Pop_Scope_Stack;
+
else
Package_Node := New_Node (N_Package_Body, Package_Sloc);
Set_Defining_Unit_Name (Package_Node, Name_Node);
+ -- Move the aspect specifications to the body node
+
+ if Has_Aspects (Dummy_Node) then
+ Move_Aspects (From => Dummy_Node, To => Package_Node);
+ end if;
+
-- In SPARK, a HIDE directive can be placed at the beginning of a
-- package implementation, thus hiding the package body from SPARK
-- tool-set. No violation of the SPARK restriction should be
Set_Name (Package_Node, P_Qualified_Simple_Name);
No_Constraint;
+ P_Aspect_Specifications (Package_Node, Semicolon => False);
TF_Semicolon;
Pop_Scope_Stack;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
-- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- TASK_BODY ::=
- -- task body DEFINING_IDENTIFIER is
+ -- task body DEFINING_IDENTIFIER [ASPECT_SPECIFICATIONS] is
-- DECLARATIVE_PART
-- begin
-- HANDLED_SEQUENCE_OF_STATEMENTS
-- end [task_IDENTIFIER]
-- TASK_BODY_STUB ::=
- -- task body DEFINING_IDENTIFIER is separate;
+ -- task body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATIONS];
-- This routine scans out a task declaration, task body, or task stub
-- Error recovery: cannot raise Error_Resync
function P_Task return Node_Id is
- Name_Node : Node_Id;
- Task_Node : Node_Id;
- Task_Sloc : Source_Ptr;
+ Aspect_Sloc : Source_Ptr;
+ Name_Node : Node_Id;
+ Task_Node : Node_Id;
+ Task_Sloc : Source_Ptr;
+
+ Dummy_Node : constant Node_Id := New_Node (N_Task_Body, Token_Ptr);
+ -- Placeholder node used to hold legal or prematurely declared aspect
+ -- specifications. Depending on the context, the aspect specifications
+ -- may be moved to a new node.
begin
Push_Scope_Stack;
Discard_Junk_List (P_Known_Discriminant_Part_Opt);
end if;
+ if Aspect_Specifications_Present then
+ Aspect_Sloc := Token_Ptr;
+ P_Aspect_Specifications (Dummy_Node, Semicolon => False);
+ end if;
+
TF_Is;
-- Task stub
Scan; -- past SEPARATE
Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
Set_Defining_Identifier (Task_Node, Name_Node);
+
+ if Has_Aspects (Dummy_Node) then
+ Error_Msg
+ ("aspect specifications must come after SEPARATE",
+ Aspect_Sloc);
+ end if;
+
+ P_Aspect_Specifications (Task_Node, Semicolon => False);
TF_Semicolon;
Pop_Scope_Stack; -- remove unused entry
else
Task_Node := New_Node (N_Task_Body, Task_Sloc);
Set_Defining_Identifier (Task_Node, Name_Node);
+
+ -- Move the aspect specifications to the body node
+
+ if Has_Aspects (Dummy_Node) then
+ Move_Aspects (From => Dummy_Node, To => Task_Node);
+ end if;
+
Parse_Decls_Begin_End (Task_Node);
end if;
-- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- PROTECTED_BODY ::=
- -- protected body DEFINING_IDENTIFIER is
+ -- protected body DEFINING_IDENTIFIER
+ -- [ASPECT_SPECIFICATIONS]
+ -- is
-- {PROTECTED_OPERATION_ITEM}
-- end [protected_IDENTIFIER];
-- PROTECTED_BODY_STUB ::=
- -- protected body DEFINING_IDENTIFIER is separate;
+ -- protected body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATIONS];
-- This routine scans out a protected declaration, protected body
-- or a protected stub.
-- Error recovery: cannot raise Error_Resync
function P_Protected return Node_Id is
+ Aspect_Sloc : Source_Ptr;
Name_Node : Node_Id;
Protected_Node : Node_Id;
Protected_Sloc : Source_Ptr;
Scan_State : Saved_Scan_State;
+ Dummy_Node : constant Node_Id := New_Node (N_Protected_Body, Token_Ptr);
+ -- Placeholder node used to hold legal or prematurely declared aspect
+ -- specifications. Depending on the context, the aspect specifications
+ -- may be moved to a new node.
+
begin
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Name;
Discard_Junk_List (P_Known_Discriminant_Part_Opt);
end if;
+ if Aspect_Specifications_Present then
+ Aspect_Sloc := Token_Ptr;
+ P_Aspect_Specifications (Dummy_Node, Semicolon => False);
+ end if;
+
TF_Is;
-- Protected stub
if Token = Tok_Separate then
Scan; -- past SEPARATE
+
Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
Set_Defining_Identifier (Protected_Node, Name_Node);
+
+ if Has_Aspects (Dummy_Node) then
+ Error_Msg
+ ("aspect specifications must come after SEPARATE",
+ Aspect_Sloc);
+ end if;
+
+ P_Aspect_Specifications (Protected_Node, Semicolon => False);
TF_Semicolon;
Pop_Scope_Stack; -- remove unused entry
else
Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
Set_Defining_Identifier (Protected_Node, Name_Node);
+
+ Move_Aspects (From => Dummy_Node, To => Protected_Node);
Set_Declarations (Protected_Node, P_Protected_Operation_Items);
End_Statements (Protected_Node);
end if;
-- ENTRY_DECLARATION ::=
-- [OVERRIDING_INDICATOR]
- -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
- -- PARAMETER_PROFILE;
+ -- entry DEFINING_IDENTIFIER
+ -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE
-- [ASPECT_SPECIFICATIONS];
-- The caller has checked that the initial token is ENTRY, NOT or
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
-------------------------------
procedure Analyze_Package_Body_Stub (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- Nam : Entity_Id;
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Nam : Entity_Id;
begin
-- The package declaration must be in the current declarative part
SCO_Record (Unum);
end if;
+ -- Propagate any aspect specifications associated with
+ -- with the stub to the proper body.
+
+ Move_Or_Merge_Aspects
+ (From => N, To => Proper_Body (Unit (Comp_Unit)));
+
-- Analyze the unit if semantics active
if not Fatal_Error (Unum) or else Try_Semantics then
----------------------------
procedure Analyze_Task_Body_Stub (N : Node_Id) is
- Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
Loc : constant Source_Ptr := Sloc (N);
+ Nam : Entity_Id := Current_Entity_In_Scope (Defining_Identifier (N));
begin
Check_Stub_Level (N);
-- Warnings
when Aspect_Warnings =>
-
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Set_Has_Delayed_Aspects (E);
Record_Rep_Item (E, Aspect);
+ -- When delay is not required and the context is a package body,
+ -- insert the pragma in the declarations of the body.
+
+ elsif Nkind (N) = N_Package_Body then
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List);
+ end if;
+
+ -- The pragma is added before source declarations
+
+ Prepend_To (Declarations (N), Aitem);
+
-- When delay is not required and the context is not a compilation
-- unit, we simply insert the pragma/attribute definition clause
-- in sequence.
-- a corresponding spec, but for which there may also be a spec_id.
if Has_Aspects (N) then
- if Present (Spec_Id) then
+
+ -- Aspects that apply to a body stub are relocated to the proper
+ -- body. Do not emit an error in this case.
+
+ if Present (Spec_Id)
+ and then Nkind (N) not in N_Body_Stub
+ and then Nkind (Parent (N)) /= N_Subunit
+ then
Error_Msg_N
("aspect specifications must appear in subprogram declaration",
N);
-- the later is never used for name resolution. In this fashion there
-- is only one visible entity that denotes the package.
- -- Set Body_Id. Note that this Will be reset to point to the generic
+ -- Set Body_Id. Note that this will be reset to point to the generic
-- copy later on in the generic case.
Body_Id := Defining_Entity (N);
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Body_Id);
+ end if;
+
if Present (Corresponding_Spec (N)) then
-- Body is body of package instantiation. Corresponding spec has
-- True when this package declaration is not a nested declaration
begin
- -- Analye aspect specifications immediately, since we need to recognize
+ -- Analyze aspect specifications immediately, since we need to recognize
-- things like Pure early enough to diagnose violations during analysis.
if Has_Aspects (N) then
Set_Ekind (Body_Id, E_Protected_Body);
Spec_Id := Find_Concurrent_Spec (Body_Id);
+ -- Protected bodies are currently removed by the expander. Since there
+ -- are no language-defined aspects that apply to a protected body, it is
+ -- not worth changing the whole expansion to accomodate user-defined
+ -- aspects. Plus we cannot possibly known the semantics of user-defined
+ -- aspects in order to plan ahead.
+
+ if Has_Aspects (N) then
+ Error_Msg_N
+ ("?user-defined aspects on protected bodies are not supported", N);
+
+ -- The aspects are removed for now to prevent cascading errors down
+ -- stream.
+
+ Remove_Aspects (N);
+ end if;
+
if Present (Spec_Id)
and then Ekind (Spec_Id) = E_Protected_Type
then
-- disastrous result.
Analyze_Protected_Type_Declaration (N);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Single_Protected_Declaration;
-------------------------------------
Set_Scope (Body_Id, Current_Scope);
Spec_Id := Find_Concurrent_Spec (Body_Id);
+ -- Task bodies are transformed into a subprogram spec and body pair by
+ -- the expander. Since there are no language-defined aspects that apply
+ -- to a task body, it is not worth changing the whole expansion to
+ -- accomodate user-defined aspects. Plus we cannot possibly known the
+ -- semantics of user-defined aspects in order to plan ahead.
+
+ if Has_Aspects (N) then
+ Error_Msg_N
+ ("?user-defined aspects on task bodies are not supported", N);
+
+ -- The aspects are removed for now to prevent cascading errors down
+ -- stream.
+
+ Remove_Aspects (N);
+ end if;
+
-- The spec is either a task type declaration, or a single task
-- declaration for which we have created an anonymous type.
Stmt := Prev (Stmt);
end loop;
- -- If we get here, then we ran out of preceding statements. The
- -- pragma is immediately within a body.
+ -- Handle all cases where the pragma is actually an aspect and
+ -- applies to a library-level package spec, body or subprogram.
- if Nkind_In (Context, N_Package_Body,
- N_Subprogram_Body)
+ -- function F ... with SPARK_Mode => ...;
+ -- package P with SPARK_Mode => ...;
+ -- package body P with SPARK_Mode => ... is
+
+ -- The following circuitry simply prepares the proper context
+ -- for the general pragma processing mechanism below.
+
+ if Nkind (Context) = N_Compilation_Unit_Aux then
+ Context := Unit (Parent (Context));
+
+ if Nkind_In (Context, N_Package_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Context := Specification (Context);
+ end if;
+ end if;
+
+ -- The pragma is at the top level of a package spec or appears
+ -- as an aspect on a subprogram.
+
+ -- function F ... with SPARK_Mode => ...;
+
+ -- package P is
+ -- pragma SPARK_Mode;
+
+ if Nkind_In (Context, N_Function_Specification,
+ N_Package_Specification,
+ N_Procedure_Specification)
+ then
+ Spec_Id := Defining_Unit_Name (Context);
+ Chain_Pragma (Spec_Id, N);
+
+ -- The pragma is immediately within a package or subprogram
+ -- body.
+
+ -- function F ... is
+ -- pragma SPARK_Mode;
+
+ -- package body P is
+ -- pragma SPARK_Mode;
+
+ elsif Nkind_In (Context, N_Package_Body,
+ N_Subprogram_Body)
then
Spec_Id := Corresponding_Spec (Context);
Chain_Pragma (Body_Id, N);
Check_Conformance (Spec_Id, Body_Id);
- -- The pragma is at the top level of a package spec
-
- elsif Nkind (Context) = N_Package_Specification then
- Spec_Id := Defining_Unit_Name (Context);
- Chain_Pragma (Spec_Id, N);
-
-- The pragma applies to the statements of a package body
+ -- package body P is
+ -- begin
+ -- pragma SPARK_Mode;
+
elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (Context)) = N_Package_Body
then
-- and put in its proper section when we know exactly where that is!
-- EXPRESSION_FUNCTION ::=
- -- FUNCTION SPECIFICATION IS (EXPRESSION);
+ -- FUNCTION SPECIFICATION IS (EXPRESSION)
+ -- [ASPECT_SPECIFICATIONS];
-- N_Expression_Function
-- Sloc points to FUNCTION
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
- -- is [[abstract] tagged] [limited] private;
+ -- is [[abstract] tagged] [limited] private
+ -- [ASPECT_SPECIFICATIONS];
-- Note: TAGGED is not permitted in Ada 83 mode
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] [limited | synchronized]
-- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
- -- with private;
+ -- with private [ASPECT_SPECIFICATIONS];
-- Note: LIMITED, and private extension declarations are not allowed
-- in Ada 83 mode.
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER :
- -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER :
- -- ACCESS_DEFINITION renames object_NAME;
+ -- ACCESS_DEFINITION renames object_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- Note: Access_Definition is an optional field that gives support to
-- Ada 2005 (AI-230). The parser generates nodes that have either the
-----------------------------------------
-- EXCEPTION_RENAMING_DECLARATION ::=
- -- DEFINING_IDENTIFIER : exception renames exception_NAME;
+ -- DEFINING_IDENTIFIER : exception renames exception_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- N_Exception_Renaming_Declaration
-- Sloc points to first identifier
---------------------------------------
-- PACKAGE_RENAMING_DECLARATION ::=
- -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME;
+ -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- N_Package_Renaming_Declaration
-- Sloc points to PACKAGE
------------------------------------------
-- SUBPROGRAM_RENAMING_DECLARATION ::=
- -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
+ -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- N_Subprogram_Renaming_Declaration
-- Sloc points to RENAMES
-- GENERIC_RENAMING_DECLARATION ::=
-- generic package DEFINING_PROGRAM_UNIT_NAME
-- renames generic_package_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | generic procedure DEFINING_PROGRAM_UNIT_NAME
-- renames generic_procedure_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- | generic function DEFINING_PROGRAM_UNIT_NAME
-- renames generic_function_NAME
+ -- [ASPECT_SPECIFICATIONS];
-- N_Generic_Package_Renaming_Declaration
-- Sloc points to GENERIC
-- ENTRY_DECLARATION ::=
-- [[not] overriding]
-- entry DEFINING_IDENTIFIER
- -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE;
+ -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE
+ -- [ASPECT_SPECIFICATIONS];
-- N_Entry_Declaration
-- Sloc points to ENTRY
----------------------------------
-- SUBPROGRAM_BODY_STUB ::=
- -- SUBPROGRAM_SPECIFICATION is separate;
+ -- SUBPROGRAM_SPECIFICATION is separate
+ -- [ASPECT_SPECIFICATION];
-- N_Subprogram_Body_Stub
-- Sloc points to FUNCTION or PROCEDURE
-------------------------------
-- PACKAGE_BODY_STUB ::=
- -- package body DEFINING_IDENTIFIER is separate;
+ -- package body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATION];
-- N_Package_Body_Stub
-- Sloc points to PACKAGE
----------------------------
-- TASK_BODY_STUB ::=
- -- task body DEFINING_IDENTIFIER is separate;
+ -- task body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATION];
-- N_Task_Body_Stub
-- Sloc points to TASK
---------------------------------
-- PROTECTED_BODY_STUB ::=
- -- protected body DEFINING_IDENTIFIER is separate;
+ -- protected body DEFINING_IDENTIFIER is separate
+ -- [ASPECT_SPECIFICATION];
-- Note: protected body stubs are not allowed in Ada 83 mode
------------------------------------------
-- GENERIC_SUBPROGRAM_DECLARATION ::=
- -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION;
+ -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION
+ -- [ASPECT_SPECIFICATIONS];
-- Note: Generic_Formal_Declarations can include pragmas
("-gnatc must be first if combined with other switches");
end if;
+ -- Not allowed if previous -gnatR given
+
+ if List_Representation_Info /= 0 then
+ Osint.Fail
+ ("-gnatc not allowed since -gnatR given previously");
+ end if;
+
Ptr := Ptr + 1;
Operating_Mode := Check_Semantics;
("-gnatR not permitted since -gnatD given previously");
end if;
+ -- Not allowed if previous -gnatc was given, since we must
+ -- call the code generator to determine rep information.
+
+ if Operating_Mode = Check_Semantics then
+ Osint.Fail
+ ("-gnatR not permitted since -gnatc given previously");
+ end if;
+
-- Set to annotate rep info, and set default -gnatR mode
Back_Annotate_Rep_Info := True;
projects / thirdparty / gcc.git / commitdiff
