OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_ch6.adb (Is_Public_Subprogram_For): New procedure

Browse Source 
2011-11-21  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb (Is_Public_Subprogram_For): New procedure
	(Process_PPCs): Invariants only apply to public subprograms.

2011-11-21  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb, sem_util.ads, sem_attr.adb, restrict.adb,
	restrict.ads: Fix for No_Implicit_Aliasing in the renames case.

2011-11-21  Robert Dewar  <dewar@adacore.com>

	* a-finali.ads: Use pragma Pure_12 for this unit
	* aspects.adb: Add aspect Pure_12
	* aspects.ads: Add aspect Pure_12
	* opt.ads: Add note on Pure_12
	* par-prag.adb: Add dummy entry for Pure_12
	* sem_prag.adb: Implement Pure_12 pragma
	* snames.ads-tmpl: Add Entry for Pure_12

2011-11-21  Sergey Rybin  <rybin@adacore.com frybin>

	* vms_data.ads: Add qualifiers for new gnatpp options
	'--call_threshold' and '--par_threshold".
	* gnat_ugn.texi: Add description for new gnatpp options
	'--call_threshold' and '--par_threshold".

2011-11-21  Robert Dewar  <dewar@adacore.com>

	* lib.ads: Minor reformatting.

2011-11-21  Robert Dewar  <dewar@adacore.com>

	* lib-load.ads: Add comment.

From-SVN: r181563
This commit is contained in:
Arnaud Charlet 2011-11-21 12:35:55 +01:00
parent 4bf201ed2f
commit a4901c0835
18 changed files with 274 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -1,3 +1,38 @@
2011-11-21 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb (Is_Public_Subprogram_For): New procedure
(Process_PPCs): Invariants only apply to public subprograms.
2011-11-21 Robert Dewar <dewar@adacore.com>
* sem_util.adb, sem_util.ads, sem_attr.adb, restrict.adb,
restrict.ads: Fix for No_Implicit_Aliasing in the renames case.
2011-11-21 Robert Dewar <dewar@adacore.com>
* a-finali.ads: Use pragma Pure_12 for this unit
* aspects.adb: Add aspect Pure_12
* aspects.ads: Add aspect Pure_12
* opt.ads: Add note on Pure_12
* par-prag.adb: Add dummy entry for Pure_12
* sem_prag.adb: Implement Pure_12 pragma
* snames.ads-tmpl: Add Entry for Pure_12
2011-11-21 Sergey Rybin <rybin@adacore.com frybin>
* vms_data.ads: Add qualifiers for new gnatpp options
'--call_threshold' and '--par_threshold".
* gnat_ugn.texi: Add description for new gnatpp options
'--call_threshold' and '--par_threshold".
2011-11-21 Robert Dewar <dewar@adacore.com>
* lib.ads: Minor reformatting.
2011-11-21 Robert Dewar <dewar@adacore.com>
* lib-load.ads: Add comment.
2011-11-21 Gary Dismukes <dismukes@adacore.com>
* sem_elab.adb: Minor reformatting

6
gcc/ada/a-finali.ads
View File

@ -34,14 +34,16 @@
------------------------------------------------------------------------------
pragma Warnings (Off);
-- System.Finalization_Root does not have category Remote_Types, but we
-- allow it anyway.
with System.Finalization_Root;
pragma Warnings (On);
package Ada.Finalization is
pragma Pure_12;
-- Ada.Finalization is declared pure in Ada 2012 (AI05-0212)
pragma Preelaborate;
pragma Remote_Types;
-- The above apply in versions of Ada before Ada 2012
type Controlled is abstract tagged private;
pragma Preelaborable_Initialization (Controlled);

1
gcc/ada/aspects.adb
View File

@ -255,6 +255,7 @@ package body Aspects is
Aspect_Preelaborate_05 => Aspect_Preelaborate_05,
Aspect_Pure => Aspect_Pure,
Aspect_Pure_05 => Aspect_Pure_05,
Aspect_Pure_12 => Aspect_Pure_12,
Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface,
Aspect_Remote_Types => Aspect_Remote_Types,
Aspect_Shared_Passive => Aspect_Shared_Passive,

3
gcc/ada/aspects.ads
View File

@ -96,6 +96,7 @@ package Aspects is
Aspect_Preelaborate_05, -- GNAT
Aspect_Pure,
Aspect_Pure_05, -- GNAT
Aspect_Pure_12, -- GNAT
Aspect_Remote_Call_Interface,
Aspect_Remote_Types,
Aspect_Shared_Passive,
@ -154,6 +155,7 @@ package Aspects is
Aspect_Compiler_Unit => True,
Aspect_Preelaborate_05 => True,
Aspect_Pure_05 => True,
Aspect_Pure_12 => True,
Aspect_Universal_Data => True,
Aspect_Ada_2005 => True,
Aspect_Ada_2012 => True,
@ -324,6 +326,7 @@ package Aspects is
Aspect_Priority => Name_Priority,
Aspect_Pure => Name_Pure,
Aspect_Pure_05 => Name_Pure_05,
Aspect_Pure_12 => Name_Pure_12,
Aspect_Pure_Function => Name_Pure_Function,
Aspect_Read => Name_Read,
Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,

13
gcc/ada/gnat_ugn.texi
View File

@ -13364,6 +13364,19 @@ and variants if there are @var{nnn} or more (the default
value is 10).
If @var{nnn} is 0, an additional indentation level is
used for @b{case} alternatives and variants regardless of their number.
@item ^--call_threshold=@var{nnn}^/MAX_ACT=@var{nnn}^
@cindex @option{^--call_threshold^/MAX_ACT^} (@command{gnatpp})
If the number of parameter associations is greater than @var{nnn} and if at
least one association uses named notation, start each association from
a new line. If @var{nnn} is 0, no check for the number of associations
is made, this is the default.
@item ^--par_threshold=@var{nnn}^/MAX_PAR=@var{nnn}^
@cindex @option{^--par_threshold^/MAX_PAR^} (@command{gnatpp})
If the number of parameter specifications is greater than @var{nnn}
(or equal to @var{nnn} in case of a function), start each specification from
a new line. The default for @var{nnn} is 3.
@end table
@node Setting the Source Search Path

3
gcc/ada/lib-load.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -155,6 +155,7 @@ package Lib.Load is
--
-- PMES indicates the required setting of Parsing_Main_Extended_Unit during
-- loading of the unit. This flag is saved and restored over the call.
-- Note: PMES is false for the subunit case, which seems wrong???
procedure Change_Main_Unit_To_Spec;
-- This procedure is called if the main unit file contains a No_Body pragma

4
gcc/ada/lib.ads
View File

@ -518,7 +518,7 @@ package Lib is
-- its subunits (considered recursively). Units for which this enquiry
-- returns True are those for which code will be generated. Nodes from
-- instantiations are included in the extended main unit for this call.
-- If the main unit is itself a subunit, then the extended main unit
-- If the main unit is itself a subunit, then the extended main code unit
-- includes its parent unit, and the parent unit spec if it is separate.
function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean;
@ -533,7 +533,7 @@ package Lib is
-- returns True are those for which code will be generated. This differs
-- from In_Extended_Main_Code_Unit only in that instantiations are not
-- included for the purposes of this call. If the main unit is itself
-- a subunit, then the extended main unit includes its parent unit,
-- a subunit, then the extended main source unit includes its parent unit,
-- and the parent unit spec if it is separate.
function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean;

2
gcc/ada/opt.ads
View File

@ -140,7 +140,7 @@ package Opt is
-- or internal units, so it reflects the Ada version explicitly set
-- using configuration pragmas or compiler switches (or if neither
-- appears, it remains set to Ada_Version_Default). This is used in
-- the rare cases (notably for pragmas Preelaborate_05 and Pure_05)
-- the rare cases (notably for pragmas Preelaborate_05 and Pure_05/12)
-- where in the run-time we want the explicit version set.
Ada_Version_Runtime : Ada_Version_Type := Ada_2012;

1
gcc/ada/par-prag.adb
View File

@ -1216,6 +1216,7 @@ begin
Pragma_Psect_Object |
Pragma_Pure |
Pragma_Pure_05 |
Pragma_Pure_12 |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Relative_Deadline |

72
gcc/ada/restrict.adb
View File

@ -183,6 +183,78 @@ package body Restrict is
end if;
end Check_SPARK_Restriction;
--------------------------------
-- Check_No_Implicit_Aliasing --
--------------------------------
procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
E : Entity_Id;
begin
-- If restriction not active, nothing to check
if not Restriction_Active (No_Implicit_Aliasing) then
return;
end if;
-- If we have an entity name, check entity
if Is_Entity_Name (Obj) then
E := Entity (Obj);
-- Restriction applies to entities that are objects
if Is_Object (E) then
if Is_Aliased (E) then
return;
elsif Present (Renamed_Object (E)) then
Check_No_Implicit_Aliasing (Renamed_Object (E));
return;
end if;
-- If we don't have an object, then it's OK
else
return;
end if;
-- For selected component, check selector
elsif Nkind (Obj) = N_Selected_Component then
Check_No_Implicit_Aliasing (Selector_Name (Obj));
return;
-- Indexed component is OK if aliased components
elsif Nkind (Obj) = N_Indexed_Component then
if Has_Aliased_Components (Etype (Prefix (Obj)))
or else
(Is_Access_Type (Etype (Prefix (Obj)))
and then Has_Aliased_Components
(Designated_Type (Etype (Prefix (Obj)))))
then
return;
end if;
-- For type conversion, check converted expression
elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
Check_No_Implicit_Aliasing (Expression (Obj));
return;
-- Explicit dereference is always OK
elsif Nkind (Obj) = N_Explicit_Dereference then
return;
end if;
-- If we fall through, then we have an aliased view that does not meet
-- the rules for being explicitly aliased, so issue restriction msg.
Check_Restriction (No_Implicit_Aliasing, Obj);
end Check_No_Implicit_Aliasing;
-----------------------------------------
-- Check_Implicit_Dynamic_Code_Allowed --
-----------------------------------------

7
gcc/ada/restrict.ads
View File

@ -279,6 +279,13 @@ package Restrict is
-- Same as Check_SPARK_Restriction except there is a continuation message
-- Msg2 following the initial message Msg1.
procedure Check_No_Implicit_Aliasing (Obj : Node_Id);
-- Obj is a node for which Is_Aliased_View is True, which is being used in
-- a context (e.g. 'Access) where no implicit aliasing is allowed if the
-- restriction No_Implicit_Aliasing is set. This procedure checks for the
-- case where the restriction is active and Obj does not meet the required
-- rules for avoiding implicit aliases, and issues a restriction message.
procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id);
-- Tests to see if dynamic code generation (dynamically generated
-- trampolines, in particular) is allowed by the current restrictions

11
gcc/ada/sem_attr.adb
View File

@ -841,13 +841,8 @@ package body Sem_Attr is
and then not In_Instance
and then not In_Inlined_Body
then
if Restriction_Check_Required (No_Implicit_Aliasing) then
Error_Attr_P
("prefix of % attribute must be explicitly aliased");
else
Error_Attr_P
("prefix of % attribute must be aliased");
end if;
Error_Attr_P ("prefix of % attribute must be aliased");
Check_No_Implicit_Aliasing (P);
end if;
end Analyze_Access_Attribute;
@ -2245,6 +2240,8 @@ package body Sem_Attr is
if Restriction_Check_Required (No_Implicit_Aliasing) then
if not Is_Aliased_View (P) then
Check_Restriction (No_Implicit_Aliasing, P);
else
Check_No_Implicit_Aliasing (P);
end if;
end if;

70
gcc/ada/sem_ch6.adb
View File

@ -8536,19 +8536,19 @@ package body Sem_Ch6 is
and then In_Private_Part (Current_Scope)
then
Priv_Decls :=
Private_Declarations (
Specification (Unit_Declaration_Node (Current_Scope)));
Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)));
return In_Package_Body (Current_Scope)
or else
(Is_List_Member (Decl)
and then List_Containing (Decl) = Priv_Decls)
and then List_Containing (Decl) = Priv_Decls)
or else (Nkind (Parent (Decl)) = N_Package_Specification
and then not
Is_Compilation_Unit
(Defining_Entity (Parent (Decl)))
and then List_Containing (Parent (Parent (Decl)))
= Priv_Decls);
and then not
Is_Compilation_Unit
(Defining_Entity (Parent (Decl)))
and then List_Containing (Parent (Parent (Decl))) =
Priv_Decls);
else
return False;
end if;
@ -9562,6 +9562,15 @@ package body Sem_Ch6 is
-- or IN OUT parameters of the subprogram, or (for a function) if the
-- return value has an invariant.
function Is_Public_Subprogram_For (T : Entity_Id) return Boolean;
-- T is the entity for a private type for which invariants are defined.
-- This function returns True if the procedure corresponding to the
-- value of Designator is a public procedure from the point of view of
-- this type (i.e. its spec is in the visible part of the package that
-- contains the declaration of the private type). A True value means
-- that an invariant check is required (for an IN OUT parameter, or
-- the returned value of a function.
--------------
-- Grab_PPC --
--------------
@ -9689,6 +9698,45 @@ package body Sem_Ch6 is
return False;
end Invariants_Or_Predicates_Present;
------------------------------
-- Is_Public_Subprogram_For --
------------------------------
-- The type T is a private type, its declaration is therefore in
-- the list of public declarations of some package. The test for a
-- public subprogram is that its declaration is in this same list
-- of declarations for the same package (note that all the public
-- declarations are in one list, and all the private declarations
-- in another, so this deals with the public/private distinction).
function Is_Public_Subprogram_For (T : Entity_Id) return Boolean is
DD : constant Node_Id := Unit_Declaration_Node (Designator);
-- The subprogram declaration for the subprogram in question
TL : constant List_Id :=
Visible_Declarations
(Specification (Unit_Declaration_Node (Scope (T))));
-- The list of declarations containing the private declaration of
-- the type. We know it is a private type, so we know its scope is
-- the package in question, and we know it must be in the visible
-- declarations of this package.
begin
-- If the subprogram declaration is not a list member, it must be
-- an Init_Proc, in which case we want to consider it to be a
-- public subprogram, since we do get initializations to deal with.
if not Is_List_Member (DD) then
return True;
-- Otherwise we test whether the subprogram is declared in the
-- visible declarations of the package containing the type.
else
return TL = List_Containing (DD);
end if;
end Is_Public_Subprogram_For;
-- Start of processing for Process_PPCs
begin
@ -9985,10 +10033,13 @@ package body Sem_Ch6 is
Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
Defining_Identifier => Rent));
-- Add invariant call if returning type with invariants
-- Add invariant call if returning type with invariants and
-- this is a public function, i.e. a function declared in the
-- visible part of the package defining the private type.
if Has_Invariants (Etype (Rent))
and then Present (Invariant_Procedure (Etype (Rent)))
and then Is_Public_Subprogram_For (Etype (Rent))
then
Append_To (Plist,
Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
@ -10017,6 +10068,7 @@ package body Sem_Ch6 is
if Has_Invariants (Ftype)
and then Present (Invariant_Procedure (Ftype))
and then Is_Public_Subprogram_For (Ftype)
then
Append_To (Plist,
Make_Invariant_Call

42
gcc/ada/sem_prag.adb
View File

@ -12647,6 +12647,47 @@ package body Sem_Prag is
end if;
end Pure_05;
-------------
-- Pure_12 --
-------------
-- pragma Pure_12 [(library_unit_NAME)];
-- This pragma is useable only in GNAT_Mode, where it is used like
-- pragma Pure but it is only effective in Ada 2012 mode (otherwise
-- it is ignored). It may be used after a pragma Preelaborate, in
-- which case it overrides the effect of the pragma Preelaborate.
-- This is used to implement AI05-0212 which recategorizes some
-- run-time packages in Ada 2012 mode.
when Pragma_Pure_12 => Pure_12 : declare
Ent : Entity_Id;
begin
GNAT_Pragma;
Check_Valid_Library_Unit_Pragma;
if not GNAT_Mode then
Error_Pragma ("pragma% only available in GNAT mode");
end if;
if Nkind (N) = N_Null_Statement then
return;
end if;
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
-- set to Ada_2012 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_2012 then
Ent := Find_Lib_Unit_Name;
Set_Is_Preelaborated (Ent, False);
Set_Is_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end Pure_12;
-------------------
-- Pure_Function --
-------------------
@ -14959,6 +15000,7 @@ package body Sem_Prag is
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_12 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,

4
gcc/ada/sem_util.adb
View File

@ -6583,10 +6583,6 @@ package body Sem_Util is
if Is_Entity_Name (Obj) then
E := Entity (Obj);
if Is_Object (E) and then not Is_Aliased (E) then
Check_Restriction (No_Implicit_Aliasing, Obj);
end if;
return
(Is_Object (E)
and then

8
gcc/ada/sem_util.ads
View File

@ -775,8 +775,12 @@ package Sem_Util is
function Is_Aliased_View (Obj : Node_Id) return Boolean;
-- Determine if Obj is an aliased view, i.e. the name of an object to which
-- 'Access or 'Unchecked_Access can apply. Note that the implementation
-- takes the No_Implicit_Aiasing restriction into account.
-- 'Access or 'Unchecked_Access can apply. Note that this routine uses the
-- rules of the language, it does not take into account the restriction
-- No_Implicit_Aliasing, so it can return True if the restriction is active
-- and Obj violates the restriction. The caller is responsible for calling
-- Restrict.Check_No_Implicit_Aliasing if True is returned, but there is a
-- requirement for obeying the restriction in the call context.
function Is_Ancestor_Package
(E1 : Entity_Id;

2
gcc/ada/snames.ads-tmpl
View File

@ -524,6 +524,7 @@ package Snames is
Name_Psect_Object : constant Name_Id := N + $; -- VMS
Name_Pure : constant Name_Id := N + $;
Name_Pure_05 : constant Name_Id := N + $; -- GNAT
Name_Pure_12 : constant Name_Id := N + $; -- GNAT
Name_Pure_Function : constant Name_Id := N + $; -- GNAT
Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05
Name_Remote_Call_Interface : constant Name_Id := N + $;
@ -1672,6 +1673,7 @@ package Snames is
Pragma_Psect_Object,
Pragma_Pure,
Pragma_Pure_05,
Pragma_Pure_12,
Pragma_Pure_Function,
Pragma_Relative_Deadline,
Pragma_Remote_Call_Interface,

18
gcc/ada/vms_data.ads
View File

@ -6200,6 +6200,14 @@ package VMS_Data is
--
-- Set the maximum line length, nnn from 32 ..256. The default is 79.
S_Pretty_Maxact : aliased constant S := "/MAX_ACT=#" &
"--call_threshold=#";
-- /MAX_ACT=nnn
--
-- If the number of parameter associations is greater than nnn and if at
-- least one association uses named notation, start each association from
-- a new line
S_Pretty_Maxind : aliased constant S := "/MAX_INDENT=#" &
"-T#";
-- /MAX_INDENT=nnn
@ -6209,6 +6217,14 @@ package VMS_Data is
-- If nnn is zero, an additional indentation level is used for any
-- number of case alternatives and variants.
S_Pretty_Maxpar : aliased constant S := "/MAX_PAR=#" &
"--par_threshold=#";
-- /MAX_PAR=nnn
--
-- If the number of parameter specifications is greater than nnn (or equal
-- to nnn in case of a function), start each specification from a new line.
-- The default value is 3.
S_Pretty_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
@ -6401,7 +6417,9 @@ package VMS_Data is
S_Pretty_Indent 'Access,
S_Pretty_Keyword 'Access,
S_Pretty_Maxlen 'Access,
S_Pretty_Maxact 'Access,
S_Pretty_Maxind 'Access,
S_Pretty_Maxpar 'Access,
S_Pretty_Mess 'Access,
S_Pretty_Names 'Access,
S_Pretty_No_Labels 'Access,