+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
-- --
-- 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- --
-- 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:
-- 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
-- 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;
-- 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
-- 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;
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
-- 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.
-
- 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;
+ -- 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.
- Insert_Actions_After (P, Post_Call);
+ 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:
+
+ -- if Clobber (X) then
+ -- Put_Line (X'Img);
+ -- else
+ -- goto Junk
+ -- end if;
+
+ -- 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.
+
+ -- 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) ???
- -- 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.
+ declare
+ Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T');
+ FRTyp : constant Entity_Id := Etype (N);
+ Name : constant Node_Id := Relocate_Node (N);
- else
+ 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));
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;
-- --
-- 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- --
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.
-- --
-- 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- --
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);
-- 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);
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");
@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
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.
-
-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
+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 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
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)
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
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;
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;
-- --
-- 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- --
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
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;
-- --
-- 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- --
-- 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 --
-------------------------------------------------
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Elists; use Elists;
with System; use System;
with Tree_IO; use Tree_IO;
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));
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));
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));
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));
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));
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));
-- --
-- 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- --
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
-- --
-- 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- --
-- 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;
projects / thirdparty / gcc.git / commitdiff
