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

[multiple changes] 

2011-08-03  Eric Botcazou  <ebotcazou@adacore.com>

	* inline.adb: Revert previous change.

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* sem_cat.adb (Validate_RCI_Subprogram_Declaration): Reject a remote
	subprogram with a limited formal that does not support external
	streaming.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* get_alfa.adb (Get_ALFA): add missing Skip_Spaces at start of
	continuation line
	* lib-xref-alfa.adb (Add_ALFA_File): split removal of scopes that are
	not from current unit in two phases, because it is not possible to
	change the table while iterating over its content.
	* put_alfa.adb (Put_ALFA): reset current file/scope at each new entity

2011-08-03  Sergey Rybin  <rybin@adacore.com>

	* vms_data.ads: Add qualifier for gnatmetric --no-static-loop option
	* gnat_ugn.texi: Update description of complexity metrics (gnatmetric)

From-SVN: r177255
This commit is contained in:
Arnaud Charlet 2011-08-03 11:56:17 +02:00
parent 668a19bcfe
commit b5ea9143e7
8 changed files with 355 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/ada/ChangeLog
View File

@ -1,3 +1,23 @@
2011-08-03 Thomas Quinot <quinot@adacore.com>
* sem_cat.adb (Validate_RCI_Subprogram_Declaration): Reject a remote
subprogram with a limited formal that does not support external
streaming.
2011-08-03 Yannick Moy <moy@adacore.com>
* get_alfa.adb (Get_ALFA): add missing Skip_Spaces at start of
continuation line
* lib-xref-alfa.adb (Add_ALFA_File): split removal of scopes that are
not from current unit in two phases, because it is not possible to
change the table while iterating over its content.
* put_alfa.adb (Put_ALFA): reset current file/scope at each new entity
2011-08-03 Sergey Rybin <rybin@adacore.com>
* vms_data.ads: Add qualifier for gnatmetric --no-static-loop option
* gnat_ugn.texi: Update description of complexity metrics (gnatmetric)
2011-08-03 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Op_Concat_Arg): if the argument is an aggregate
@ -22,7 +42,6 @@
discriminants.
* sem_type.adb (Disambiguate): an immediately visible operator hides a
user-defined function that is only use-visible.
* inline.adb: init procs are inlineable.
2011-08-03 Robert Dewar <dewar@adacore.com>

1
gcc/ada/get_alfa.adb
View File

@ -393,6 +393,7 @@ begin
Skip_EOL;
exit when Nextc /= '.';
Skipc;
Skip_Spaces;
end if;
if Nextc = '.' then

38
gcc/ada/gnat_ugn.texi
View File

@ -14360,12 +14360,14 @@ McCabe cyclomatic complexity;
McCabe essential complexity;
@item
maximal loop nesting level
maximal loop nesting level;
@item
extra exit points (for subprograms);
@end itemize
@noindent
The McCabe complexity metrics are defined
The McCabe cyclomatic complexity metric is defined
in @url{http://www.mccabe.com/pdf/mccabe-nist235r.pdf}
According to McCabe, both control statements and short-circuit control forms
@ -14386,6 +14388,34 @@ cyclomatic complexity, which is the sum of these two values.
@end itemize
@noindent
The origin of cyclomatic complexity metric is the need to estimate the number
of independent paths in the control flow graph that in turn gives the number
of tests needed to satisfy paths coverage testing completeness criterion.
Considered from the testing point of view, a static Ada @code{loop} (that is,
the @code{loop} statement having static subtype in loop parameter
specification) does not add to cyclomatic complexity. By providing
@option{^--no-static-loop^NO_STATIC_LOOP^} option a user
may specify that such loops should not be counted when computing the
cyclomatic complexity metric
The Ada essential complexity metric is a McCabe cyclomatic complexity metric
counted for the code that is reduced by excluding all the pure structural Ada
control statements. An compound statement is considered as a non-structural
if it contains a @code{raise} or @code{return} statement as it subcomponent,
or if it contains a @code{goto} statement that transfers the control outside
the operator. A selective accept statement with @code{terminate} alternative
is considered as non-structural statement. When computing this metric,
@code{exit} statements are treated in the same way as @code{goto}
statements unless @option{^-ne^NO_EXITS_AS_GOTOS^} option is specified.
The Ada essential complexity metric defined here is intended to quantify
the extent to which the software is unstructured. It is adapted from
the McCabe essential complexity metric defined in
http://www.mccabe.com/pdf/nist235r.pdf but is modified to be more
suitable for typical Ada usage. For example, short circuit forms
are not penalized as unstructured in the Ada essential complexity metric.
When computing cyclomatic and essential complexity, @command{gnatmetric} skips
the code in the exception handlers and in all the nested program units.
@ -14439,6 +14469,10 @@ bodies, task bodies, entry bodies and statement sequences in package bodies
Do not consider @code{exit} statements as @code{goto}s when
computing Essential Complexity
@cindex @option{^--no-static-loop^/NO_STATIC_LOOP^} (@command{gnatmetric})
@item ^--no-static-loop^/NO_STATIC_LOOP^
Do not consider static loops when computing cyclomatic complexity
@item ^--extra-exit-points^/EXTRA_EXIT_POINTS^
Report the extra exit points for subprogram bodies. As an exit point, this
metric counts @code{return} statements and raise statements in case when the

6
gcc/ada/inline.adb
View File

@ -349,12 +349,6 @@ package body Inline is
Set_Is_Inlined (Pack);
Inlined_Bodies.Increment_Last;
Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
-- an initialization procedure should be inlined, but it does
-- not require the body of the package.
elsif Is_Init_Proc (E) then
Set_Is_Inlined (Pack);
end if;
end if;
end;

54
gcc/ada/lib-xref-alfa.adb
View File

@ -224,25 +224,47 @@ package body ALFA is
-- Update scope numbers
for S in From .. ALFA_Scope_Table.Last loop
declare
E : Entity_Id renames ALFA_Scope_Table.Table (S).Scope_Entity;
begin
if Lib.Get_Source_Unit (E) = U then
ALFA_Scope_Table.Table (S).Scope_Num := Int (S - From) + 1;
ALFA_Scope_Table.Table (S).File_Num := D;
declare
Count : Nat;
else
-- Remove scope S which is not located in unit U, for example
-- for scope inside generics that get instantiated.
begin
Count := 1;
for S in From .. ALFA_Scope_Table.Last loop
declare
E : Entity_Id renames ALFA_Scope_Table.Table (S).Scope_Entity;
begin
if Lib.Get_Source_Unit (E) = U then
ALFA_Scope_Table.Table (S).Scope_Num := Count;
ALFA_Scope_Table.Table (S).File_Num := D;
Count := Count + 1;
for J in S .. ALFA_Scope_Table.Last - 1 loop
ALFA_Scope_Table.Table (J) := ALFA_Scope_Table.Table (J + 1);
end loop;
ALFA_Scope_Table.Set_Last (ALFA_Scope_Table.Last - 1);
else
-- Mark for removal a scope S which is not located in unit
-- U, for example for scope inside generics that get
-- instantiated.
ALFA_Scope_Table.Table (S).Scope_Num := 0;
end if;
end;
end loop;
end;
declare
Snew : Scope_Index;
begin
Snew := From;
for S in From .. ALFA_Scope_Table.Last loop
-- Remove those scopes previously marked for removal
if ALFA_Scope_Table.Table (S).Scope_Num /= 0 then
ALFA_Scope_Table.Table (Snew) := ALFA_Scope_Table.Table (S);
Snew := Snew + 1;
end if;
end;
end loop;
end loop;
ALFA_Scope_Table.Set_Last (Snew - 1);
end;
-- Make entry for new file in file table

4
gcc/ada/put_alfa.adb
View File

@ -141,8 +141,6 @@ begin
Write_Info_Char (S.Scope_Name (N));
end loop;
File := F.File_Num;
Scope := S.Scope_Num;
Entity_Line := 0;
Entity_Col := 0;
@ -175,6 +173,8 @@ begin
Entity_Line := R.Entity_Line;
Entity_Col := R.Entity_Col;
File := F.File_Num;
Scope := S.Scope_Num;
end if;
if Write_Info_Col > 72 then

535
gcc/ada/sem_cat.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- 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- --
@ -35,6 +35,7 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Attr; use Sem_Attr;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
@ -68,13 +69,21 @@ package body Sem_Cat is
-- that no component is declared with a nonstatic default value.
-- If a nonstatic default exists, report an error on Obj_Decl.
-- Iterate through the component list of a record definition, check
-- that no component is declared with a non-static default value.
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if entity has attribute definition clauses for Read and
-- Write attributes that are visible at some place.
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if the entity or one of its subcomponents is of an access
-- type that does not have user-defined Read and Write attributes visible
-- at any place.
function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
-- Returns true if the entity is a type whose full view is a non-remote
-- access type, for the purpose of enforcing E.2.2(8) rules.
function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean;
-- Return true if Typ or the type of any of its subcomponents is a non
-- remote access type and doesn't have user-defined stream attributes.
function No_External_Streaming (E : Entity_Id) return Boolean;
-- Return True if the entity or one of its subcomponents does not support
-- external streaming.
function In_RCI_Declaration (N : Node_Id) return Boolean;
-- Determines if a declaration is within the visible part of a Remote
@ -85,10 +94,6 @@ package body Sem_Cat is
-- Determines if current scope is within the declaration of a Remote Types
-- unit, for semantic checking purposes.
function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
-- Returns true if the entity is a type whose full view is a non-remote
-- access type, for the purpose of enforcing E.2.2(8) rules.
function In_Shared_Passive_Unit return Boolean;
-- Determines if current scope is within a Shared Passive compilation unit
@ -104,6 +109,12 @@ package body Sem_Cat is
-- also constraints about the primitive subprograms of the class-wide type.
-- RM E.2 (9, 13, 14)
procedure Validate_RACW_Primitive
(Subp : Entity_Id;
RACW : Entity_Id);
-- Check legality of the declaration of primitive Subp of the designated
-- type of the given RACW type.
---------------------------------------
-- Check_Categorization_Dependencies --
---------------------------------------
@ -346,6 +357,62 @@ package body Sem_Cat is
end loop;
end Check_Non_Static_Default_Expr;
---------------------------
-- Has_Non_Remote_Access --
---------------------------
function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean is
Component : Entity_Id;
Comp_Type : Entity_Id;
U_Typ : constant Entity_Id := Underlying_Type (Typ);
begin
if No (U_Typ) then
return False;
elsif Has_Read_Write_Attributes (Typ)
or else Has_Read_Write_Attributes (U_Typ)
then
return False;
elsif Is_Non_Remote_Access_Type (U_Typ) then
return True;
end if;
if Is_Record_Type (U_Typ) then
Component := First_Entity (U_Typ);
while Present (Component) loop
if not Is_Tag (Component) then
Comp_Type := Etype (Component);
if Has_Non_Remote_Access (Comp_Type) then
return True;
end if;
end if;
Next_Entity (Component);
end loop;
elsif Is_Array_Type (U_Typ) then
return Has_Non_Remote_Access (Component_Type (U_Typ));
end if;
return False;
end Has_Non_Remote_Access;
-------------------------------
-- Has_Read_Write_Attributes --
-------------------------------
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
begin
return True
and then Has_Stream_Attribute_Definition (E,
TSS_Stream_Read, At_Any_Place => True)
and then Has_Stream_Attribute_Definition (E,
TSS_Stream_Write, At_Any_Place => True);
end Has_Read_Write_Attributes;
-------------------------------------
-- Has_Stream_Attribute_Definition --
-------------------------------------
@ -555,64 +622,29 @@ package body Sem_Cat is
and then not Is_Remote_Access_To_Subprogram_Type (U_E);
end Is_Non_Remote_Access_Type;
----------------------------------
-- Missing_Read_Write_Attribute --
----------------------------------
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
Component : Entity_Id;
Component_Type : Entity_Id;
U_E : constant Entity_Id := Underlying_Type (E);
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if entity has attribute definition clauses for Read and
-- Write attributes that are visible at some place.
-------------------------------
-- Has_Read_Write_Attributes --
-------------------------------
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
begin
return True
and then Has_Stream_Attribute_Definition (E,
TSS_Stream_Read, At_Any_Place => True)
and then Has_Stream_Attribute_Definition (E,
TSS_Stream_Write, At_Any_Place => True);
end Has_Read_Write_Attributes;
-- Start of processing for Missing_Read_Write_Attributes
---------------------------
-- No_External_Streaming --
---------------------------
function No_External_Streaming (E : Entity_Id) return Boolean is
U_E : constant Entity_Id := Underlying_Type (E);
begin
if No (U_E) then
return False;
elsif Has_Read_Write_Attributes (E)
or else Has_Read_Write_Attributes (U_E)
then
elsif Has_Read_Write_Attributes (E) then
-- Note: availability of stream attributes is tested on E, not U_E.
-- There may be stream attributes defined on U_E that are not visible
-- at the place where support of external streaming is tested.
return False;
elsif Is_Non_Remote_Access_Type (U_E) then
elsif Has_Non_Remote_Access (U_E) then
return True;
end if;
if Is_Record_Type (U_E) then
Component := First_Entity (U_E);
while Present (Component) loop
if not Is_Tag (Component) then
Component_Type := Etype (Component);
if Missing_Read_Write_Attributes (Component_Type) then
return True;
end if;
end if;
Next_Entity (Component);
end loop;
end if;
return False;
end Missing_Read_Write_Attributes;
return Is_Limited_Type (E);
end No_External_Streaming;
-------------------------------------
-- Set_Categorization_From_Pragmas --
@ -1311,6 +1343,120 @@ package body Sem_Cat is
end Validate_Object_Declaration;
-----------------------------
-- Validate_RACW_Primitive --
-----------------------------
procedure Validate_RACW_Primitive
(Subp : Entity_Id;
RACW : Entity_Id)
is
procedure Illegal_Remote_Subp (Msg : String; N : Node_Id);
-- Diagnose illegality on N. If RACW is present, report the error on it
-- rather than on N.
-------------------------
-- Illegal_Remote_Subp --
-------------------------
procedure Illegal_Remote_Subp (Msg : String; N : Node_Id) is
begin
if Present (RACW) then
if not Error_Posted (RACW) then
Error_Msg_N
("illegal remote access to class-wide type&", RACW);
end if;
Error_Msg_Sloc := Sloc (N);
Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp);
else
Error_Msg_NE (Msg & " in remote subprogram&", N, Subp);
end if;
end Illegal_Remote_Subp;
Rtyp : Entity_Id;
Param : Node_Id;
Param_Spec : Node_Id;
Param_Type : Entity_Id;
-- Start of processing for Validate_RACW_Primitive
begin
-- Check return type
if Ekind (Subp) = E_Function then
Rtyp := Etype (Subp);
if Has_Controlling_Result (Subp) then
null;
elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
Illegal_Remote_Subp ("anonymous access result", Rtyp);
elsif Is_Limited_Type (Rtyp) then
if No (TSS (Rtyp, TSS_Stream_Read))
or else
No (TSS (Rtyp, TSS_Stream_Write))
then
Illegal_Remote_Subp
("limited return type must have Read and Write attributes",
Parent (Subp));
Explain_Limited_Type (Rtyp, Parent (Subp));
-- Check that the return type supports external streaming.
-- Note that the language of the standard (E.2.2(14)) does not
-- explicitly mention that case, but it really does not make
-- sense to return a value containing a local access type.
elsif No_External_Streaming (Rtyp)
and then not Error_Posted (Rtyp)
then
Illegal_Remote_Subp ("return type containing non-remote access "
& "must have Read and Write attributes",
Parent (Subp));
end if;
end if;
end if;
Param := First_Formal (Subp);
while Present (Param) loop
-- Now find out if this parameter is a controlling parameter
Param_Spec := Parent (Param);
Param_Type := Etype (Param);
if Is_Controlling_Formal (Param) then
-- It is a controlling parameter, so specific checks below do not
-- apply.
null;
elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
then
-- From RM E.2.2(14), no anonymous access parameter other than
-- controlling ones may be used (because an anonymous access
-- type never supports external streaming).
Illegal_Remote_Subp
("non-controlling access parameter", Param_Spec);
elsif No_External_Streaming (Param_Type)
and then not Error_Posted (Param_Type)
then
Illegal_Remote_Subp ("formal parameter in remote subprogram must "
& "support external streaming", Param_Spec);
end if;
-- Check next parameter in this subprogram
Next_Formal (Param);
end loop;
end Validate_RACW_Primitive;
------------------------------
-- Validate_RACW_Primitives --
------------------------------
@ -1320,35 +1466,6 @@ package body Sem_Cat is
Primitive_Subprograms : Elist_Id;
Subprogram_Elmt : Elmt_Id;
Subprogram : Entity_Id;
Param_Spec : Node_Id;
Param : Entity_Id;
Param_Type : Entity_Id;
Rtyp : Node_Id;
procedure Illegal_RACW (Msg : String; N : Node_Id);
-- Diagnose that T is illegal because of the given reason, associated
-- with the location of node N.
Illegal_RACW_Message_Issued : Boolean := False;
-- Set True once Illegal_RACW has been called
------------------
-- Illegal_RACW --
------------------
procedure Illegal_RACW (Msg : String; N : Node_Id) is
begin
if not Illegal_RACW_Message_Issued then
Error_Msg_N
("illegal remote access to class-wide type&", T);
Illegal_RACW_Message_Issued := True;
end if;
Error_Msg_Sloc := Sloc (N);
Error_Msg_N ("\\" & Msg & " in primitive#", T);
end Illegal_RACW;
-- Start of processing for Validate_RACW_Primitives
begin
Desig_Type := Etype (Designated_Type (T));
@ -1371,96 +1488,10 @@ package body Sem_Cat is
goto Next_Subprogram;
end if;
-- Check return type
Validate_RACW_Primitive (Subp => Subprogram, RACW => T);
if Ekind (Subprogram) = E_Function then
Rtyp := Etype (Subprogram);
if Has_Controlling_Result (Subprogram) then
null;
elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
Illegal_RACW ("anonymous access result", Rtyp);
elsif Is_Limited_Type (Rtyp) then
if No (TSS (Rtyp, TSS_Stream_Read))
or else
No (TSS (Rtyp, TSS_Stream_Write))
then
Illegal_RACW
("limited return type must have Read and Write attributes",
Parent (Subprogram));
Explain_Limited_Type (Rtyp, Parent (Subprogram));
-- Check that the return type supports external streaming.
-- Note that the language of the standard (E.2.2(14)) does not
-- explicitly mention that case, but it really does not make
-- sense to return a value containing a local access type.
elsif Missing_Read_Write_Attributes (Rtyp)
and then not Error_Posted (Rtyp)
then
Illegal_RACW ("return type containing non-remote access "
& "must have Read and Write attributes",
Parent (Subprogram));
end if;
end if;
end if;
Param := First_Formal (Subprogram);
while Present (Param) loop
-- Now find out if this parameter is a controlling parameter
Param_Spec := Parent (Param);
Param_Type := Etype (Param);
if Is_Controlling_Formal (Param) then
-- It is a controlling parameter, so specific checks below
-- do not apply.
null;
elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
then
-- From RM E.2.2(14), no anonymous access parameter other than
-- controlling ones may be used (because an anonymous access
-- type never supports external streaming).
Illegal_RACW ("non-controlling access parameter", Param_Spec);
elsif Is_Limited_Type (Param_Type) then
-- Not a controlling parameter, so type must have Read and
-- Write attributes.
if No (TSS (Param_Type, TSS_Stream_Read))
or else
No (TSS (Param_Type, TSS_Stream_Write))
then
Illegal_RACW
("limited formal must have Read and Write attributes",
Param_Spec);
Explain_Limited_Type (Param_Type, Param_Spec);
end if;
elsif Missing_Read_Write_Attributes (Param_Type)
and then not Error_Posted (Param_Type)
then
Illegal_RACW ("parameter containing non-remote access "
& "must have Read and Write attributes", Param_Spec);
end if;
-- Check next parameter in this subprogram
Next_Formal (Param);
end loop;
<<Next_Subprogram>>
Next_Elmt (Subprogram_Elmt);
<<Next_Subprogram>>
Next_Elmt (Subprogram_Elmt);
end loop;
end Validate_RACW_Primitives;
@ -1487,8 +1518,7 @@ package body Sem_Cat is
Error_Msg_N ("generic declaration not allowed in rci unit",
Parent (E));
elsif (Ekind (E) = E_Function
or else Ekind (E) = E_Procedure)
elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure)
and then Has_Pragma_Inline (E)
then
Error_Msg_N
@ -1527,9 +1557,6 @@ package body Sem_Cat is
Id : Node_Id;
Param_Spec : Node_Id;
Param_Type : Entity_Id;
Base_Param_Type : Entity_Id;
Base_Under_Type : Entity_Id;
Type_Decl : Node_Id;
Error_Node : Node_Id := N;
begin
@ -1545,6 +1572,7 @@ package body Sem_Cat is
end if;
if K = N_Subprogram_Declaration then
Id := Defining_Unit_Name (Specification (N));
Profile := Parameter_Specifications (Specification (N));
else pragma Assert (K = N_Object_Declaration);
@ -1574,7 +1602,6 @@ package body Sem_Cat is
Param_Spec := First (Profile);
while Present (Param_Spec) loop
Param_Type := Etype (Defining_Identifier (Param_Spec));
Type_Decl := Parent (Param_Type);
if Ekind (Param_Type) = E_Anonymous_Access_Type then
if K = N_Subprogram_Declaration then
@ -1595,115 +1622,20 @@ package body Sem_Cat is
-- declaration and ignore full type declaration, unless this is
-- the only declaration for the type, e.g., as a limited record.
elsif Is_Limited_Type (Param_Type)
and then (Nkind (Type_Decl) = N_Private_Type_Declaration
or else
(Nkind (Type_Decl) = N_Full_Type_Declaration
and then not (Has_Private_Declaration (Param_Type))
and then Comes_From_Source (N)))
then
-- A limited parameter is legal only if user-specified Read and
-- Write attributes exist for it. Second part of RM E.2.3 (14).
if No (Full_View (Param_Type))
and then Ekind (Param_Type) /= E_Record_Type
then
-- Type does not have completion yet, so if declared in
-- the current RCI scope it is illegal, and will be flagged
-- subsequently.
return;
end if;
-- In Ada 95 the rules permit using a limited type that has
-- user-specified Read and Write attributes that are specified
-- in the private part of the package, whereas Ada 2005
-- (AI-240) revises this to require the attributes to be
-- "available" (implying that the attribute clauses must be
-- visible to the RCI client). The Ada 95 rules violate the
-- contract model for privacy, but we support both semantics
-- for now for compatibility (note that ACATS test BXE2009
-- checks a case that conforms to the Ada 95 rules but is
-- illegal in Ada 2005). In the Ada 2005 case we check for the
-- possibilities of visible TSS stream subprograms or explicit
-- stream attribute definitions because the TSS subprograms
-- can be hidden in the private part while the attribute
-- definitions are still be available from the visible part.
Base_Param_Type := Base_Type (Param_Type);
Base_Under_Type := Base_Type (Underlying_Type
(Base_Param_Type));
if (Ada_Version < Ada_2005
and then
(No (TSS (Base_Param_Type, TSS_Stream_Read))
or else
No (TSS (Base_Param_Type, TSS_Stream_Write)))
and then
(No (TSS (Base_Under_Type, TSS_Stream_Read))
or else
No (TSS (Base_Under_Type, TSS_Stream_Write))))
or else
(Ada_Version >= Ada_2005
and then
(No (TSS (Base_Param_Type, TSS_Stream_Read))
or else
No (TSS (Base_Param_Type, TSS_Stream_Write))
or else
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read))
or else
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))
and then
(not Has_Stream_Attribute_Definition
(Base_Param_Type, TSS_Stream_Read)
or else
not Has_Stream_Attribute_Definition
(Base_Param_Type, TSS_Stream_Write)))
then
if K = N_Subprogram_Declaration then
Error_Node := Param_Spec;
end if;
if Ada_Version >= Ada_2005 then
Error_Msg_N
("limited parameter in 'R'C'I unit "
& "must have visible read/write attributes ",
Error_Node);
else
Error_Msg_N
("limited parameter in 'R'C'I unit "
& "must have read/write attributes ",
Error_Node);
end if;
Explain_Limited_Type (Param_Type, Error_Node);
end if;
-- In Ada 95, any non-remote access type (or any type with a
-- component of a non-remote access type) that is visible in an
-- RCI unit comes from a Remote_Types or Remote_Call_Interface
-- unit, and thus is already guaranteed to support external
-- streaming. However in Ada 2005 we have to account for the case
-- of named access types from declared pure units as well, which
-- may or may not support external streaming, and so we need to
-- perform a specific check for E.2.3(14/2) here.
-- Note that if the declaration of the type itself is illegal, we
-- do not perform this check since it might be a cascaded error.
else
elsif No_External_Streaming (Param_Type) then
if K = N_Subprogram_Declaration then
Error_Node := Param_Spec;
end if;
if Missing_Read_Write_Attributes (Param_Type)
and then not Error_Posted (Param_Type)
then
Error_Msg_N
("parameter containing non-remote access in 'R'C'I "
& "subprogram must have visible "
& "Read and Write attributes", Error_Node);
Error_Msg_NE
("formal of remote subprogram& "
& "must support external streaming",
Error_Node, Id);
if Is_Limited_Type (Param_Type) then
Explain_Limited_Type (Param_Type, Error_Node);
end if;
end if;
Next (Param_Spec);
end loop;
@ -2005,6 +1937,27 @@ package body Sem_Cat is
U_Typ : Entity_Id;
First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
function Stream_Attributes_Available (Typ : Entity_Id) return Boolean;
-- True if any stream attribute is available for Typ
---------------------------------
-- Stream_Attributes_Available --
---------------------------------
function Stream_Attributes_Available (Typ : Entity_Id) return Boolean
is
begin
return Stream_Attribute_Available (Typ, TSS_Stream_Read)
or else
Stream_Attribute_Available (Typ, TSS_Stream_Write)
or else
Stream_Attribute_Available (Typ, TSS_Stream_Input)
or else
Stream_Attribute_Available (Typ, TSS_Stream_Output);
end Stream_Attributes_Available;
-- Start of processing for Validate_RT_RAT_Component
begin
if not Is_Remote_Types (Name_U) then
return;
@ -2019,7 +1972,15 @@ package body Sem_Cat is
end if;
if Comes_From_Source (Typ) and then Is_Type (Typ) then
if Missing_Read_Write_Attributes (Typ) then
-- Check that the type can be meaningfully transmitted to another
-- partition (E.2.2(8)).
if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ))
or else
(Stream_Attributes_Available (Typ)
and then No_External_Streaming (U_Typ))
then
if Is_Non_Remote_Access_Type (Typ) then
Error_Msg_N ("error in non-remote access type", U_Typ);
else

11
gcc/ada/vms_data.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -5456,6 +5456,14 @@ package VMS_Data is
-- Do not count EXIT statements as GOTOs when computing the Essential
-- Complexity.
S_Metric_No_Static_Loop : aliased constant S := "/NO_STATIC_LOOP " &
"--no-static-loop";
-- /STATIC_LOOP (D)
-- /NO_STATIC_LOOP
--
-- Do not count static FOR loop statements when computing the Cyclomatic
-- Complexity.
S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
@ -5554,6 +5562,7 @@ package VMS_Data is
S_Metric_Mess 'Access,
S_Metric_No_Exits_As_Gotos'Access,
S_Metric_No_Local 'Access,
S_Metric_No_Static_Loop 'Access,
S_Metric_Project 'Access,
S_Metric_Quiet 'Access,
S_Metric_Suffix 'Access,