From b5ea9143e7536eb2e599ee581b06c5f21129b86b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 3 Aug 2011 11:56:17 +0200 Subject: [PATCH] [multiple changes] 2011-08-03 Eric Botcazou * inline.adb: Revert previous change. 2011-08-03 Thomas Quinot * 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 * 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 * vms_data.ads: Add qualifier for gnatmetric --no-static-loop option * gnat_ugn.texi: Update description of complexity metrics (gnatmetric) From-SVN: r177255 --- gcc/ada/ChangeLog | 21 +- gcc/ada/get_alfa.adb | 1 + gcc/ada/gnat_ugn.texi | 38 ++- gcc/ada/inline.adb | 6 - gcc/ada/lib-xref-alfa.adb | 54 ++-- gcc/ada/put_alfa.adb | 4 +- gcc/ada/sem_cat.adb | 527 ++++++++++++++++++-------------------- gcc/ada/vms_data.ads | 11 +- 8 files changed, 351 insertions(+), 311 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 403cfe79bff..90df61211d4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2011-08-03 Thomas Quinot + + * 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 + + * 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 + + * 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 * 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 diff --git a/gcc/ada/get_alfa.adb b/gcc/ada/get_alfa.adb index e78badcd0c8..94d5d9f4680 100644 --- a/gcc/ada/get_alfa.adb +++ b/gcc/ada/get_alfa.adb @@ -393,6 +393,7 @@ begin Skip_EOL; exit when Nextc /= '.'; Skipc; + Skip_Spaces; end if; if Nextc = '.' then diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e0521f44d0b..862278cb679 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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 diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 0d184dd45b2..d85e0866a48 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -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; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 94d2725b7d5..5e0edbc3e48 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -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 diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index 58021145d1b..d8819200e21 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -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 diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 83d3d6a1c5b..80f017b5938 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -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 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 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 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,156 +1343,155 @@ package body Sem_Cat is end Validate_Object_Declaration; - ------------------------------ - -- Validate_RACW_Primitives -- - ------------------------------ + ----------------------------- + -- Validate_RACW_Primitive -- + ----------------------------- - procedure Validate_RACW_Primitives (T : Entity_Id) is - Desig_Type : Entity_Id; - 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 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. - 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_Remote_Subp -- + ------------------------- - Illegal_RACW_Message_Issued : Boolean := False; - -- Set True once Illegal_RACW has been called + 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; - ------------------ - -- Illegal_RACW -- - ------------------ + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp); - 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; + else + Error_Msg_NE (Msg & " in remote subprogram&", N, Subp); end if; + end Illegal_Remote_Subp; - Error_Msg_Sloc := Sloc (N); - Error_Msg_N ("\\" & Msg & " in primitive#", T); - end Illegal_RACW; + Rtyp : Entity_Id; + Param : Node_Id; + Param_Spec : Node_Id; + Param_Type : Entity_Id; - -- Start of processing for Validate_RACW_Primitives + -- Start of processing for Validate_RACW_Primitive begin - Desig_Type := Etype (Designated_Type (T)); + -- Check return type - -- No action needed for concurrent types + if Ekind (Subp) = E_Function then + Rtyp := Etype (Subp); - if Is_Concurrent_Type (Desig_Type) then - return; - end if; - - Primitive_Subprograms := Primitive_Operations (Desig_Type); + if Has_Controlling_Result (Subp) then + null; - Subprogram_Elmt := First_Elmt (Primitive_Subprograms); - while Subprogram_Elmt /= No_Elmt loop - Subprogram := Node (Subprogram_Elmt); + elsif Ekind (Rtyp) = E_Anonymous_Access_Type then + Illegal_Remote_Subp ("anonymous access result", Rtyp); - if Is_Predefined_Dispatching_Operation (Subprogram) - or else Is_Hidden (Subprogram) - then - goto Next_Subprogram; + 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; - -- Check return type + Param := First_Formal (Subp); + while Present (Param) loop - if Ekind (Subprogram) = E_Function then - Rtyp := Etype (Subprogram); + -- Now find out if this parameter is a controlling parameter - if Has_Controlling_Result (Subprogram) then - null; + Param_Spec := Parent (Param); + Param_Type := Etype (Param); - elsif Ekind (Rtyp) = E_Anonymous_Access_Type then - Illegal_RACW ("anonymous access result", Rtyp); + if Is_Controlling_Formal (Param) then - 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; + -- It is a controlling parameter, so specific checks below do not + -- apply. - end if; - end if; + null; - Param := First_Formal (Subprogram); - while Present (Param) loop + 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). - -- Now find out if this parameter is a controlling parameter + Illegal_Remote_Subp + ("non-controlling access parameter", Param_Spec); - Param_Spec := Parent (Param); - Param_Type := Etype (Param); + 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; - if Is_Controlling_Formal (Param) then + -- Check next parameter in this subprogram - -- It is a controlling parameter, so specific checks below - -- do not apply. + Next_Formal (Param); + end loop; + end Validate_RACW_Primitive; - null; + ------------------------------ + -- Validate_RACW_Primitives -- + ------------------------------ - 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). + procedure Validate_RACW_Primitives (T : Entity_Id) is + Desig_Type : Entity_Id; + Primitive_Subprograms : Elist_Id; + Subprogram_Elmt : Elmt_Id; + Subprogram : Entity_Id; - Illegal_RACW ("non-controlling access parameter", Param_Spec); + begin + Desig_Type := Etype (Designated_Type (T)); - elsif Is_Limited_Type (Param_Type) then + -- No action needed for concurrent types - -- Not a controlling parameter, so type must have Read and - -- Write attributes. + if Is_Concurrent_Type (Desig_Type) then + return; + end if; - 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; + Primitive_Subprograms := Primitive_Operations (Desig_Type); - 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; + Subprogram_Elmt := First_Elmt (Primitive_Subprograms); + while Subprogram_Elmt /= No_Elmt loop + Subprogram := Node (Subprogram_Elmt); - -- Check next parameter in this subprogram + if Is_Predefined_Dispatching_Operation (Subprogram) + or else Is_Hidden (Subprogram) + then + goto Next_Subprogram; + end if; - Next_Formal (Param); - end loop; + Validate_RACW_Primitive (Subp => Subprogram, RACW => T); - <> - Next_Elmt (Subprogram_Elmt); + <> + 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 diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 3d66e1833b6..75fd41485d3 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -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, -- 2.30.2