mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-19 18:20:56 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-05-21  Robert Dewar  <dewar@adacore.com>

	* stand.adb (Tree_Read): Read missing entities.
	(Tree_Write): Write missing entities.

2014-05-21  Ben Brosgol  <brosgol@adacore.com>

	* gnat_ugn.texi: Wordsmithing edits to Coupling Metrics Control
	section in gnatmetric chapter.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* exp_ch6.adb (Expand_Actuals): Spec moved here, since not used
	outside Exp_Ch6 (Expand_Actuals): Deal with proper insertion of
	post-call copy write back (see detailed comment in code).
	* exp_ch6.ads (Expand_Actuals): Moved to body, not used outside
	Exp_Ch6.
	* tbuild.ads: Minor reformatting.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* stand.ads: Add warning about adding new entities and
	Tree_Read/Tree_Write.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb (Set_Entity_With_Checks): Don't complain about
	references to restricted entities within the units in which they
	are declared.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* gnat1drv.adb (Check_Bad_Body): Use Source_File_Is_Body to
	simplify the needed test, and also deal with failure to catch
	situations with non-standard names.
	* sinput-l.ads, sinput-l.adb (Source_File_Is_No_Body): New function
	(Source_File_Is_Subunit): Removed, no longer used.

2014-05-21  Javier Miranda  <miranda@adacore.com>

	* exp_ch4.adb
	(Expand_Allocator_Expression.Apply_Accessibility_Check): for a
	renaming of an access to interface object there is no need to
	generate extra code to reference the tag.

From-SVN: r210696
This commit is contained in:
Arnaud Charlet 2014-05-21 14:39:44 +02:00
parent 77a40ec16a
commit da574a866b
12 changed files with 456 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -1,3 +1,48 @@
2014-05-21 Robert Dewar <dewar@adacore.com>
* stand.adb (Tree_Read): Read missing entities.
(Tree_Write): Write missing entities.
2014-05-21 Ben Brosgol <brosgol@adacore.com>
* gnat_ugn.texi: Wordsmithing edits to Coupling Metrics Control
section in gnatmetric chapter.
2014-05-21 Robert Dewar <dewar@adacore.com>
* exp_ch6.adb (Expand_Actuals): Spec moved here, since not used
outside Exp_Ch6 (Expand_Actuals): Deal with proper insertion of
post-call copy write back (see detailed comment in code).
* exp_ch6.ads (Expand_Actuals): Moved to body, not used outside
Exp_Ch6.
* tbuild.ads: Minor reformatting.
2014-05-21 Robert Dewar <dewar@adacore.com>
* stand.ads: Add warning about adding new entities and
Tree_Read/Tree_Write.
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_util.adb (Set_Entity_With_Checks): Don't complain about
references to restricted entities within the units in which they
are declared.
2014-05-21 Robert Dewar <dewar@adacore.com>
* gnat1drv.adb (Check_Bad_Body): Use Source_File_Is_Body to
simplify the needed test, and also deal with failure to catch
situations with non-standard names.
* sinput-l.ads, sinput-l.adb (Source_File_Is_No_Body): New function
(Source_File_Is_Subunit): Removed, no longer used.
2014-05-21 Javier Miranda <miranda@adacore.com>
* exp_ch4.adb
(Expand_Allocator_Expression.Apply_Accessibility_Check): for a
renaming of an access to interface object there is no need to
generate extra code to reference the tag.
2014-05-21 Robert Dewar <dewar@adacore.com>
* errout.adb, erroutc.adb, erroutc.ads: Allow warning tag in pragma

22
gcc/ada/exp_ch4.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -831,13 +831,25 @@ package body Exp_Ch4 is
-- Step 2: Create the accessibility comparison
-- Reference the tag: for a renaming of an access to an interface
-- object Obj_Ref already references the tag of the secondary
-- dispatch table.
if Present (Parent (Entity (Obj_Ref)))
and then Present (Renamed_Object (Entity (Obj_Ref)))
and then Is_Interface (DesigT)
then
null;
-- Generate:
-- Ref'Tag
Obj_Ref :=
Make_Attribute_Reference (Loc,
Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
else
Obj_Ref :=
Make_Attribute_Reference (Loc,
Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
end if;
-- For tagged types, determine the accessibility level by looking
-- at the type specific data of the dispatch table. Generate:

164
gcc/ada/exp_ch6.adb
View File

@ -165,6 +165,41 @@ package body Exp_Ch6 is
-- the values are not changed for the call, we know immediately that
-- we have an infinite recursion.
procedure Expand_Actuals (N : in out Node_Id; Subp : Entity_Id);
-- For each actual of an in-out or out parameter which is a numeric
-- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration:
--
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- A := TypeA (Temp);
--
-- after the call. Here TypeA is the actual type of variable A. For out
-- parameters, the initial declaration has no expression. If A is not an
-- entity name, we generate instead:
--
-- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
-- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
--
-- For all parameter modes, actuals that denote components and slices of
-- packed arrays are expanded into suitable temporaries.
--
-- For non-scalar objects that are possibly unaligned, add call by copy
-- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
--
-- The parameter N is IN OUT because in some cases, the expansion code
-- rewrites the call as an expression actions with the call inside. In
-- this case N is reset to point to the inside call so that the caller
-- can continue processing of this call.
procedure Expand_Ctrl_Function_Call (N : Node_Id);
-- N is a function call which returns a controlled object. Transform the
-- call into a temporary which retrieves the returned object from the
@ -939,7 +974,7 @@ package body Exp_Ch6 is
-- Expand_Actuals --
--------------------
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is
procedure Expand_Actuals (N : in out Node_Id; Subp : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Actual : Node_Id;
Formal : Entity_Id;
@ -976,10 +1011,10 @@ package body Exp_Ch6 is
-- the effect that this might lead to unaligned arguments.
function Make_Var (Actual : Node_Id) return Entity_Id;
-- Returns an entity that refers to the given actual parameter,
-- Actual (not including any type conversion). If Actual is an
-- entity name, then this entity is returned unchanged, otherwise
-- a renaming is created to provide an entity for the actual.
-- Returns an entity that refers to the given actual parameter, Actual
-- (not including any type conversion). If Actual is an entity name,
-- then this entity is returned unchanged, otherwise a renaming is
-- created to provide an entity for the actual.
procedure Reset_Packed_Prefix;
-- The expansion of a packed array component reference is delayed in
@ -1604,8 +1639,8 @@ package body Exp_Ch6 is
-- Also pass by copy if change of representation
or else not Same_Representation
(Etype (Formal),
Etype (Expression (Actual))))
(Etype (Formal),
Etype (Expression (Actual))))
then
Add_Call_By_Copy_Code;
@ -1809,7 +1844,7 @@ package body Exp_Ch6 is
if In_Open_Scopes (Entity (Actual)) then
Rewrite (Actual,
(Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
Name => New_Occurrence_Of (RTE (RE_Self), Loc))));
Analyze (Actual);
-- A task type cannot otherwise appear as an actual
@ -1831,36 +1866,93 @@ package body Exp_Ch6 is
-- Cases where the call is not a member of a statement list
if not Is_List_Member (N) then
declare
P : Node_Id := Parent (N);
begin
-- In Ada 2012 the call may be a function call in an expression
-- (since OUT and IN OUT parameters are now allowed for such
-- calls. The write-back of (in)-out parameters is handled
-- by the back-end, but the constraint checks generated when
-- subtypes of formal and actual don't match must be inserted
-- in the form of assignments, at the nearest point after the
-- declaration or statement that contains the call.
-- In Ada 2012 the call may be a function call in an expression
-- (since OUT and IN OUT parameters are now allowed for such
-- calls). The write-back of (in)-out parameters is handled
-- by the back-end, but the constraint checks generated when
-- subtypes of formal and actual don't match must be inserted
-- in the form of assignments.
if Ada_Version >= Ada_2012
and then Nkind (N) = N_Function_Call
then
while Nkind (P) not in N_Declaration
and then
Nkind (P) not in N_Statement_Other_Than_Procedure_Call
loop
P := Parent (P);
end loop;
if Ada_Version >= Ada_2012
and then Nkind (N) = N_Function_Call
then
-- We used to just do handle this by climbing up parents to
-- a non-statement/declaration and then simply making a call
-- to Insert_Actions_After (P, Post_Call), but that doesn't
-- work. If we are in the middle of an expression, e.g. the
-- condition of an IF, this call would insert after the IF
-- statement, which is much too late to be doing the write
-- back. For example:
Insert_Actions_After (P, Post_Call);
-- if Clobber (X) then
-- Put_Line (X'Img);
-- else
-- goto Junk
-- end if;
-- If not the special Ada 2012 case of a function call, then
-- we must have the triggering statement of a triggering
-- alternative or an entry call alternative, and we can add
-- the post call stuff to the corresponding statement list.
-- Now assume Clobber changes X, if we put the write back
-- after the IF, the Put_Line gets the wrong value and the
-- goto causes the write back to be skipped completely.
else
-- To deal with this, we replace the call by
-- do
-- Tnnn : function-result-type renames function-call;
-- Post_Call actions
-- in
-- Tnnn;
-- end;
-- Note: this won't do in Modify_Tree_For_C mode, but we
-- will deal with that later (it will require creating a
-- declaration for Temp, using Insert_Declaration) ???
declare
Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
FRTyp : constant Entity_Id := Etype (N);
Name : constant Node_Id := Relocate_Node (N);
begin
Prepend_To (Post_Call,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Tnnn,
Subtype_Mark => New_Occurrence_Of (FRTyp, Loc),
Name => Name));
Rewrite (N,
Make_Expression_With_Actions (Loc,
Actions => Post_Call,
Expression => New_Occurrence_Of (Tnnn, Loc)));
-- We don't want to just blindly call Analyze_And_Resolve
-- because that would cause unwanted recursion on the call.
-- So for a moment set the call as analyzed to prevent that
-- recursion, and get the rest analyzed properly, then reset
-- the analyzed flag, so our caller can continue.
Set_Analyzed (Name, True);
Analyze_And_Resolve (N, FRTyp);
Set_Analyzed (Name, False);
-- Reset calling argument to point to function call inside
-- the expression with actions so the caller can continue
-- to process the call.
N := Name;
end;
-- If not the special Ada 2012 case of a function call, then
-- we must have the triggering statement of a triggering
-- alternative or an entry call alternative, and we can add
-- the post call stuff to the corresponding statement list.
else
declare
P : Node_Id;
begin
P := Parent (N);
pragma Assert (Nkind_In (P, N_Triggering_Alternative,
N_Entry_Call_Alternative));
@ -1870,15 +1962,17 @@ package body Exp_Ch6 is
else
Set_Statements (P, Post_Call);
end if;
end if;
end;
return;
end;
end if;
-- Otherwise, normal case where N is in a statement sequence,
-- just put the post-call stuff after the call statement.
else
Insert_Actions_After (N, Post_Call);
return;
end if;
end if;

32
gcc/ada/exp_ch6.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -37,36 +37,6 @@ package Exp_Ch6 is
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id);
procedure Expand_N_Subprogram_Declaration (N : Node_Id);
procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-- For each actual of an in-out or out parameter which is a numeric
-- (view) conversion of the form T (A), where A denotes a variable,
-- we insert the declaration:
--
-- Temp : T[ := T (A)];
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
-- A := TypeA (Temp);
--
-- after the call. Here TypeA is the actual type of variable A. For out
-- parameters, the initial declaration has no expression. If A is not an
-- entity name, we generate instead:
--
-- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
-- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
--
-- For all parameter modes, actuals that denote components and slices of
-- packed arrays are expanded into suitable temporaries.
--
-- For non-scalar objects that are possibly unaligned, add call by copy
-- code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
procedure Expand_Call (N : Node_Id);
-- This procedure contains common processing for Expand_N_Function_Call,
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.

25
gcc/ada/gnat1drv.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -633,7 +633,6 @@ procedure Gnat1drv is
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body name
-- (but how can we have a body name here???)
if not Is_Body_Name (Sname) then
Sname := Get_Body_Name (Sname);
@ -651,19 +650,15 @@ procedure Gnat1drv is
-- to include both in a partition, this is diagnosed at bind time. In
-- Ada 83 mode this is not a warning case.
-- Note: if weird file names are being used, we can have a situation
-- where the file name that supposedly contains body in fact contains
-- a spec, or we can't tell what it contains. Skip the error message
-- in these cases.
-- Also ignore body that is nothing but pragma No_Body; (that's the
-- whole point of this pragma, to be used this way and to cause the
-- body file to be ignored in this context).
-- Note that in general we do not give the message if the file in
-- question does not look like a body. This includes weird cases,
-- but in particular means that if the file is just a No_Body pragma,
-- then we won't give the message (that's the whole point of this
-- pragma, to be used this way and to cause the body file to be
-- ignored in this context).
if Src_Ind /= No_Source_File
and then Get_Expected_Unit_Type (Fname) = Expect_Body
and then not Source_File_Is_Subunit (Src_Ind)
and then not Source_File_Is_No_Body (Src_Ind)
and then Source_File_Is_Body (Src_Ind)
then
Errout.Finalize (Last_Call => False);
@ -693,8 +688,8 @@ procedure Gnat1drv is
else
-- For generic instantiations, we never allow a body
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
if Nkind (Original_Node (Unit (Main_Unit_Node))) in
N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for $$ does not allow a body");

136
gcc/ada/gnat_ugn.texi
View File

@ -16232,50 +16232,48 @@ Do not report the extra exit points for subprogram bodies
@cindex Coupling metrics control in @command{gnatmetric}
@noindent
@cindex Coupling metrics (in in @command{gnatmetric})
@cindex Coupling metrics (in @command{gnatmetric})
Coupling metrics measure the dependencies between a given entity and other
entities the program consists of. The goal of these metrics is to estimate the
stability of the whole program considered as the collection of entities
(modules, classes etc.).
entities in the program. This information is useful since high coupling
may signal potential issues with maintainability as the program evolves.
Gnatmetric computes the following coupling metrics:
@command{gnatmetric} computes the following coupling metrics:
@itemize @bullet
@item
@emph{object-oriented coupling} - for classes in traditional object-oriented
@emph{object-oriented coupling}, for classes in traditional object-oriented
sense;
@item
@emph{unit coupling} - for all the program units making up a program;
@emph{unit coupling}, for all the program units making up a program;
@item
@emph{control coupling} - this metric counts dependencies between a unit and
only those units that define subprograms;
@emph{control coupling}, reflecting dependencies between a unit and
other units that contain subprograms.
@end itemize
@noindent
Two kinds of coupling metrics are computed:
@table @asis
@item fan-out coupling (efferent coupling)
@itemize @bullet
@item fan-out coupling (``efferent coupling''):
@cindex fan-out coupling
@cindex efferent coupling
the number of entities the given entity depends upon. It
estimates in what extent the given entity depends on the changes in
``external world''
the number of entities the given entity depends upon. This metric
reflects how the given entity depends on the changes in the
``external world''.
@item fan-in coupling (afferent coupling)
@item fan-in coupling (``afferent'' coupling):
@cindex fan-in coupling
@cindex afferent coupling
the number of entities that depend on a given entity.
It estimates in what extent the ``external world'' depends on the changes in a
given entity
@end table
This metric reflects how the ``external world'' depends on the changes in a
given entity.
@end itemize
@noindent
Object-oriented coupling metrics are metrics that measure the dependencies
Object-oriented coupling metrics measure the dependencies
between a given class (or a group of classes) and the other classes in the
program. In this subsection the term ``class'' is used in its traditional
object-oriented programming sense (an instantiable module that contains data
@ -16292,68 +16290,78 @@ that depend upon @code{K}.
A category's fan-in coupling is the number of classes outside the
category that depend on classes belonging to the category.
Ada's implementation of the object-oriented paradigm does not use the
traditional class notion, so the definition of the coupling
Ada's object-oriented paradigm separates the instantiable entity
(type) from the module (package), so the definition of the coupling
metrics for Ada maps the class and class category notions
onto Ada constructs.
For the coupling metrics, several kinds of modules -- a library package,
a library generic package, and a library generic package instantiation --
that define a tagged type or an interface type are
considered to be a class. A category consists of a library package (or
For the coupling metrics, several kinds of modules that define a tagged type
or an interface type -- library packages, library generic packages, and
library generic package instantiations -- are considered to be classes.
A category consists of a library package (or
a library generic package) that defines a tagged or an interface type,
together with all its descendant (generic) packages that define tagged
or interface types. That is a
category is an Ada hierarchy of library-level program units. So class coupling
in case of Ada is called as tagged coupling, and category coupling - as
hierarchy coupling.
or interface types. Thus a
category is an Ada hierarchy of library-level program units. Class
coupling in Ada is referred to as ``tagged coupling'', and category coupling
is referred to as ``hierarchy coupling''.
For any package counted as a class, its body and subunits (if any) are
considered together with its spec when counting the dependencies, and coupling
metrics are reported for spec units only. For dependencies between classes,
the Ada semantic dependencies are considered. For object-oriented coupling
metrics, only dependencies on units that are considered as classes, are
For any package serving as a class, its body and subunits (if any) are
considered together with its spec when computing dependencies, and coupling
metrics are reported for spec units only. Dependencies between classes
mean Ada semantic dependencies. For object-oriented coupling
metrics, only dependencies on units treated as classes are
considered.
For unit and control coupling also not compilation units but program units are
counted. That is, for a package, its spec, its body and its subunits (if any)
are considered as making up one unit, and the dependencies that are counted
are the dependencies of all these compilation units collected together as
the dependencies as a (whole) unit. And metrics are reported for spec
compilation units only (or for a subprogram body unit in case if there is no
Similarly, for unit and control coupling an entity is considered to be the
conceptual construct consisting of the entity's specification, body, and
any subunits (transitively).
@command{gnatmetric} computes
the dependencies of all these units as a whole, but
metrics are only reported for spec
units (or for a subprogram body unit in case if there is no
separate spec for the given subprogram).
For unit coupling, dependencies between all kinds of program units are
considered. For control coupling, for each unit the dependencies of this unit
upon units that define subprograms are counted, so control fan-out coupling
is reported for all units, but control fan-in coupling - only for the units
For unit coupling, dependencies are computed between all kinds of program
units. For control coupling, the dependencies of a given unit are limited to
those units that define subprograms. Thus control fan-out coupling is reported
for all units, but control fan-in coupling is only reported for units
that define subprograms.
The following simple example illustrates the difference between unit coupling
and control coupling metrics:
@smallexample @c ada
@group
package Lib_1 is
function F_1 (I : Integer) return Integer;
end Lib_1;
@end group
@group
package Lib_2 is
type T_2 is new Integer;
end Lib_2;
@end group
@group
package body Lib_1 is
function F_1 (I : Integer) return Integer is
begin
return I + 1;
end F_1;
end Lib_1;
@end group
@group
with Lib_2; use Lib_2;
package Pack is
Var : T_2;
function Fun (I : Integer) return Integer;
end Pack;
@end group
@group
with Lib_1; use Lib_1;
package body Pack is
function Fun (I : Integer) return Integer is
@ -16361,13 +16369,15 @@ package body Pack is
return F_1 (I);
end Fun;
end Pack;
@end group
@end smallexample
@noindent
if we apply @command{gnatmetric} with @code{--coupling-all} option to these
units, the result will be:
If we apply @command{gnatmetric} with the @option{--coupling-all} option to
these units, the result will be:
@smallexample
@group
Coupling metrics:
=================
Unit Lib_1 (C:\customers\662\L406-007\lib_1.ads)
@ -16375,45 +16385,49 @@ Coupling metrics:
control fan-in coupling : 1
unit fan-out coupling : 0
unit fan-in coupling : 1
@end group
@group
Unit Pack (C:\customers\662\L406-007\pack.ads)
control fan-out coupling : 1
control fan-in coupling : 0
unit fan-out coupling : 2
unit fan-in coupling : 0
@end group
@group
Unit Lib_2 (C:\customers\662\L406-007\lib_2.ads)
control fan-out coupling : 0
unit fan-out coupling : 0
unit fan-in coupling : 1
@end group
@end smallexample
@noindent
The result does not contain values for object-oriented
coupling because none of the argument unit contains a tagged type and
coupling because none of the argument units contains a tagged type and
therefore none of these units can be treated as a class.
@code{Pack} (considered as a program unit, that is spec+body) depends on two
units - @code{Lib_1} @code{and Lib_2}, therefore it has unit fan-out coupling
equals to 2. And nothing depend on it, so its unit fan-in coupling is 0 as
well as control fan-in coupling. Only one of the units @code{Pack} depends
The @code{Pack} package (spec and body) depends on two
units -- @code{Lib_1} @code{and Lib_2} -- and so its unit fan-out coupling
is 2. Since nothing depends on it, its unit fan-in coupling is 0, as
is its control fan-in coupling. Only one of the units @code{Pack} depends
upon defines a subprogram, so its control fan-out coupling is 1.
@code{Lib_2} depends on nothing, so fan-out metrics for it are 0. It does
not define a subprogram, so control fan-in metric cannot be applied to it,
and there is one unit that depends on it (@code{Pack}), so it has
unit fan-in coupling equals to 1.
@code{Lib_2} depends on nothing, so its fan-out metrics are 0. It does
not define any subprograms, so it has no control fan-in metric.
One unit (@code{Pack}) depends on it , so its unit fan-in coupling is 1.
@code{Lib_1} is similar to @code{Lib_2}, but it does define a subprogram.
So it has control fan-in coupling equals to 1 (because there is a unit
Its control fan-in coupling is 1 (because there is one unit
depending on it).
When computing coupling metrics, @command{gnatmetric} counts only
dependencies between units that are arguments of the @command{gnatmetric}
call. Coupling metrics are program-wide (or project-wide) metrics, so to
get a valid result, you should call @command{gnatmetric} for
the whole set of sources that make up your program. It can be done
by calling @command{gnatmetric} from the GNAT driver with @option{-U}
invocation. Coupling metrics are program-wide (or project-wide) metrics, so
you should invoke @command{gnatmetric} for
the complete set of sources comprising your program. This can be done
by invoking @command{gnatmetric} from the GNAT driver with the @option{-U}
option (see @ref{The GNAT Driver and Project Files} for details).
By default, all the coupling metrics are disabled. You can use the following

9
gcc/ada/sem_util.adb
View File

@ -15877,6 +15877,11 @@ package body Sem_Util is
if Restriction_Check_Required (No_Abort_Statements)
and then (Is_RTE (Val, RE_Abort_Task))
-- A special extra check, don't complain about a reference from within
-- the Ada.Task_Identification package itself!
and then not In_Same_Extended_Unit (N, Val)
then
Check_Restriction (No_Abort_Statements, Post_Node);
end if;
@ -15892,6 +15897,10 @@ package body Sem_Util is
Is_RTE (Val, RE_Exchange_Handler) or else
Is_RTE (Val, RE_Detach_Handler) or else
Is_RTE (Val, RE_Reference))
-- A special extra check, don't complain about a reference from within
-- the Ada.Interrupts package itself!
and then not In_Same_Extended_Unit (N, Val)
then
Check_Restriction (No_Dynamic_Attachment, Post_Node);
end if;

128
gcc/ada/sinput-l.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -795,9 +795,106 @@ package body Sinput.L is
Prep_Buffer (Prep_Buffer_Last) := C;
end Put_Char_In_Prep_Buffer;
-----------------------------------
-- Source_File_Is_Pragma_No_Body --
-----------------------------------
-------------------------
-- Source_File_Is_Body --
-------------------------
function Source_File_Is_Body (X : Source_File_Index) return Boolean is
Pcount : Natural;
begin
Initialize_Scanner (No_Unit, X);
-- Loop to look for subprogram or package body
loop
case Token is
-- PRAGMA, WITH, USE (which can appear before a body)
when Tok_Pragma | Tok_With | Tok_Use =>
-- We just want to skip any of these, do it by skipping to a
-- semicolon, but check for EOF, in case we have bad syntax.
loop
if Token = Tok_Semicolon then
Scan;
exit;
elsif Token = Tok_EOF then
return False;
else
Scan;
end if;
end loop;
-- PACKAGE
when Tok_Package =>
Scan; -- Past PACKAGE
-- We have a body if and only if BODY follows
return Token = Tok_Body;
-- FUNCTION or PROCEDURE
when Tok_Procedure | Tok_Function =>
Pcount := 0;
-- Loop through tokens following PROCEDURE or FUNCTION
loop
Scan;
case Token is
-- For parens, count paren level (note that paren level
-- can get greater than 1 if we have default parameters).
when Tok_Left_Paren =>
Pcount := Pcount + 1;
when Tok_Right_Paren =>
Pcount := Pcount - 1;
-- EOF means something weird, probably no body
when Tok_EOF =>
return False;
-- BEGIN or IS or END definitely means body is present
when Tok_Begin | Tok_Is | Tok_End =>
return True;
-- Semicolon means no body present if at outside any
-- parens. If within parens, ignore, since it could be
-- a parameter separator.
when Tok_Semicolon =>
if Pcount = 0 then
return False;
end if;
-- Skip anything else
when others =>
null;
end case;
end loop;
-- Anything else in main scan means we don't have a body
when others =>
return False;
end case;
end loop;
end Source_File_Is_Body;
----------------------------
-- Source_File_Is_No_Body --
----------------------------
function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
begin
@ -826,27 +923,4 @@ package body Sinput.L is
return Token = Tok_EOF;
end Source_File_Is_No_Body;
----------------------------
-- Source_File_Is_Subunit --
----------------------------
function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
begin
Initialize_Scanner (No_Unit, X);
-- We scan past junk to the first interesting compilation unit token, to
-- see if it is SEPARATE. We ignore WITH keywords during this and also
-- PRIVATE. The reason for ignoring PRIVATE is that it handles some
-- error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
while Token = Tok_With
or else Token = Tok_Private
or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
loop
Scan;
end loop;
return Token = Tok_Separate;
end Source_File_Is_Subunit;
end Sinput.L;

15
gcc/ada/sinput-l.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -64,19 +64,16 @@ package Sinput.L is
-- Called on completing the parsing of a source file. This call completes
-- the source file table entry for the current source file.
function Source_File_Is_Body (X : Source_File_Index) return Boolean;
-- Returns true if the designated source file contains a subprogram body
-- or a package body. This is a limited scan just to determine the answer
-- to this question..
function Source_File_Is_No_Body (X : Source_File_Index) return Boolean;
-- Returns true if the designated source file contains pragma No_Body;
-- and no other tokens. If the source file contains anything other than
-- this sequence of three tokens, then False is returned.
function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
-- This function determines if a source file represents a subunit. It
-- works by scanning for the first compilation unit token, and returning
-- True if it is the token SEPARATE. It will return False otherwise,
-- meaning that the file cannot possibly be a legal subunit. This
-- function does NOT do a complete parse of the file, or build a
-- tree. It is used in the main driver in the check for bad bodies.
-------------------------------------------------
-- Subprograms for Dealing With Instantiations --
-------------------------------------------------

59
gcc/ada/stand.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -29,6 +29,7 @@
-- --
------------------------------------------------------------------------------
with Elists; use Elists;
with System; use System;
with Tree_IO; use Tree_IO;
@ -46,9 +47,32 @@ package body Stand is
Tree_Read_Int (Int (Standard_Package_Node));
Tree_Read_Int (Int (Last_Standard_Node_Id));
Tree_Read_Int (Int (Last_Standard_List_Id));
Tree_Read_Int (Int (Boolean_Literals (False)));
Tree_Read_Int (Int (Boolean_Literals (True)));
Tree_Read_Int (Int (Standard_Void_Type));
Tree_Read_Int (Int (Standard_Exception_Type));
Tree_Read_Int (Int (Standard_A_String));
Tree_Read_Int (Int (Standard_A_Char));
Tree_Read_Int (Int (Standard_Debug_Renaming_Type));
-- Deal with Predefined_Float_Types, which is an Elist. We wrote the
-- entities out in sequence, terminated by an Empty entry.
declare
Elmt : Entity_Id;
begin
Predefined_Float_Types := New_Elmt_List;
loop
Tree_Read_Int (Int (Elmt));
exit when Elmt = Empty;
Append_Elmt (Elmt, Predefined_Float_Types);
end loop;
end;
-- Remainder of special entities
Tree_Read_Int (Int (Any_Id));
Tree_Read_Int (Int (Any_Type));
Tree_Read_Int (Int (Any_Access));
@ -59,10 +83,12 @@ package body Stand is
Tree_Read_Int (Int (Any_Discrete));
Tree_Read_Int (Int (Any_Fixed));
Tree_Read_Int (Int (Any_Integer));
Tree_Read_Int (Int (Any_Modular));
Tree_Read_Int (Int (Any_Numeric));
Tree_Read_Int (Int (Any_Real));
Tree_Read_Int (Int (Any_Scalar));
Tree_Read_Int (Int (Any_String));
Tree_Read_Int (Int (Raise_Type));
Tree_Read_Int (Int (Universal_Integer));
Tree_Read_Int (Int (Universal_Real));
Tree_Read_Int (Int (Universal_Fixed));
@ -70,12 +96,12 @@ package body Stand is
Tree_Read_Int (Int (Standard_Integer_16));
Tree_Read_Int (Int (Standard_Integer_32));
Tree_Read_Int (Int (Standard_Integer_64));
Tree_Read_Int (Int (Standard_Unsigned_64));
Tree_Read_Int (Int (Standard_Short_Short_Unsigned));
Tree_Read_Int (Int (Standard_Short_Unsigned));
Tree_Read_Int (Int (Standard_Unsigned));
Tree_Read_Int (Int (Standard_Long_Unsigned));
Tree_Read_Int (Int (Standard_Long_Long_Unsigned));
Tree_Read_Int (Int (Standard_Unsigned_64));
Tree_Read_Int (Int (Abort_Signal));
Tree_Read_Int (Int (Standard_Op_Rotate_Left));
Tree_Read_Int (Int (Standard_Op_Rotate_Right));
@ -96,9 +122,34 @@ package body Stand is
Tree_Write_Int (Int (Standard_Package_Node));
Tree_Write_Int (Int (Last_Standard_Node_Id));
Tree_Write_Int (Int (Last_Standard_List_Id));
Tree_Write_Int (Int (Boolean_Literals (False)));
Tree_Write_Int (Int (Boolean_Literals (True)));
Tree_Write_Int (Int (Standard_Void_Type));
Tree_Write_Int (Int (Standard_Exception_Type));
Tree_Write_Int (Int (Standard_A_String));
Tree_Write_Int (Int (Standard_A_Char));
Tree_Write_Int (Int (Standard_Debug_Renaming_Type));
-- Deal with Predefined_Float_Types, which is an Elist. Write the
-- entities out in sequence, terminated by an Empty entry.
declare
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Predefined_Float_Types);
while Present (Elmt) loop
Tree_Write_Int (Int (Node (Elmt)));
Next_Elmt (Elmt);
end loop;
Tree_Write_Int (Int (Empty));
end;
-- Remainder of special entries
Tree_Write_Int (Int (Any_Id));
Tree_Write_Int (Int (Any_Type));
Tree_Write_Int (Int (Any_Access));
@ -109,10 +160,12 @@ package body Stand is
Tree_Write_Int (Int (Any_Discrete));
Tree_Write_Int (Int (Any_Fixed));
Tree_Write_Int (Int (Any_Integer));
Tree_Write_Int (Int (Any_Modular));
Tree_Write_Int (Int (Any_Numeric));
Tree_Write_Int (Int (Any_Real));
Tree_Write_Int (Int (Any_Scalar));
Tree_Write_Int (Int (Any_String));
Tree_Write_Int (Int (Raise_Type));
Tree_Write_Int (Int (Universal_Integer));
Tree_Write_Int (Int (Universal_Real));
Tree_Write_Int (Int (Universal_Fixed));
@ -120,12 +173,12 @@ package body Stand is
Tree_Write_Int (Int (Standard_Integer_16));
Tree_Write_Int (Int (Standard_Integer_32));
Tree_Write_Int (Int (Standard_Integer_64));
Tree_Write_Int (Int (Standard_Unsigned_64));
Tree_Write_Int (Int (Standard_Short_Short_Unsigned));
Tree_Write_Int (Int (Standard_Short_Unsigned));
Tree_Write_Int (Int (Standard_Unsigned));
Tree_Write_Int (Int (Standard_Long_Unsigned));
Tree_Write_Int (Int (Standard_Long_Long_Unsigned));
Tree_Write_Int (Int (Standard_Unsigned_64));
Tree_Write_Int (Int (Abort_Signal));
Tree_Write_Int (Int (Standard_Op_Rotate_Left));
Tree_Write_Int (Int (Standard_Op_Rotate_Right));

7
gcc/ada/stand.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -37,6 +37,11 @@ with Types; use Types;
package Stand is
-- Warning: the entities defined in this package are written out by the
-- Tree_Write routine, and read back in by the Tree_Read routine, so be
-- sure to modify these two routines if you add entities that are not
-- part of Standard_Entity.
type Standard_Entity_Type is (
-- This enumeration type contains an entry for each name in Standard

4
gcc/ada/tbuild.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -205,8 +205,6 @@ package Tbuild is
-- captures the value of an expression (e.g. an aggregate). It should be
-- set whenever possible to point to the expression that is being captured.
-- This is provided to get better error messages, e.g. from CodePeer.
--
-- Make_Temp_Id would probably be a better name for this function???
function Make_Unsuppress_Block
(Loc : Source_Ptr;