-- Initialize secondary tags
else
- Initialize_Tag (Full_Typ,
- Iface => Node (Iface_Elmt),
- Tag_Comp => Tag_Comp,
- Iface_Tag => Node (Iface_Tag_Elmt));
+ Initialize_Tag
+ (Typ => Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
end if;
-- Otherwise generate code to initialize the tag
if (In_Variable_Pos and then Variable_Comps)
or else (not In_Variable_Pos and then Fixed_Comps)
then
- Initialize_Tag (Full_Typ,
- Iface => Node (Iface_Elmt),
- Tag_Comp => Tag_Comp,
- Iface_Tag => Node (Iface_Tag_Elmt));
+ Initialize_Tag
+ (Typ => Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
end if;
end if;
Relaxed_RM_Semantics := True;
if not Generate_CodePeer_Messages then
+
-- Suppress compiler warnings by default when generating SCIL for
- -- CodePeer, except when combined with -gnateC where we do want
- -- to emit GNAT warnings.
+ -- CodePeer, except when combined with -gnateC where we do want to
+ -- emit GNAT warnings.
Warning_Mode := Suppress;
end if;
--------------------
procedure Append_Decoded
- (Buf : in out Bounded_String; Id : Valid_Name_Id)
+ (Buf : in out Bounded_String;
+ Id : Valid_Name_Id)
is
C : Character;
P : Natural;
------------------------
procedure Append_Unqualified
- (Buf : in out Bounded_String; Id : Valid_Name_Id)
+ (Buf : in out Bounded_String;
+ Id : Valid_Name_Id)
is
Temp : Bounded_String;
begin
-- Name_Equals --
-----------------
- function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean is
+ function Name_Equals
+ (N1 : Valid_Name_Id;
+ N2 : Valid_Name_Id) return Boolean
+ is
begin
return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
end Name_Equals;
-- names, since these are efficiently located without hashing by Name_Find
-- in any case.
- function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean;
+ function Name_Equals
+ (N1 : Valid_Name_Id;
+ N2 : Valid_Name_Id) return Boolean;
-- Return whether N1 and N2 denote the same character sequence
function Get_Name_String (Id : Valid_Name_Id) return String;
-----------------------------
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Base : constant Node_Id := Expression (N);
+ Base : constant Node_Id := Expression (N);
begin
if not Is_Composite_Type (Typ) then
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
+
Assoc : Node_Id;
Choice : Node_Id;
Index_Type : Entity_Id;
begin
Index_Type := Etype (First_Index (Typ));
+
Assoc := First (Deltas);
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
else
Analyze (Choice);
+
if Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
- -- Choice covers a range of values.
+ -- Choice covers a range of values
+
if Base_Type (Entity (Choice)) /=
Base_Type (Index_Type)
then
------------------------------------
procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Deltas : constant List_Id := Component_Associations (N);
- Assoc : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
-
- -- Variables used to verify that discriminant-dependent components
- -- appear in the same variant.
-
- Variant : Node_Id;
- Comp_Ref : Entity_Id;
-
procedure Check_Variant (Id : Entity_Id);
-- If a given component of the delta aggregate appears in a variant
-- part, verify that it is within the same variant as that of previous
-- specified variant components of the delta.
- function Nested_In (V1, V2 : Node_Id) return Boolean;
- -- Determine whether variant V1 is within variant V2.
-
function Get_Component_Type (Nam : Node_Id) return Entity_Id;
- -- Locate component with a given name and return its type. If none
- -- found report error.
+ -- Locate component with a given name and return its type. If none found
+ -- report error.
+
+ function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
+ -- Determine whether variant V1 is within variant V2
function Variant_Depth (N : Node_Id) return Integer;
-- Determine the distance of a variant to the enclosing type
procedure Check_Variant (Id : Entity_Id) is
Comp : Entity_Id;
+ Comp_Ref : Entity_Id;
Comp_Variant : Node_Id;
+ Variant : Node_Id;
begin
if not Has_Discriminants (Typ) then
return;
end if;
+ Variant := Empty;
+
Comp := First_Entity (Typ);
while Present (Comp) loop
exit when Chars (Comp) = Chars (Id);
begin
if D1 = D2
or else
- (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
+ (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
or else
- (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
+ (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
then
Error_Msg_Node_2 := Comp_Ref;
Error_Msg_NE
end if;
end Check_Variant;
+ ------------------------
+ -- Get_Component_Type --
+ ------------------------
+
+ function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Nam) then
+ if Ekind (Comp) = E_Discriminant then
+ Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ end if;
+
+ return Etype (Comp);
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ return Any_Type;
+ end Get_Component_Type;
+
---------------
-- Nested_In --
---------------
function Nested_In (V1, V2 : Node_Id) return Boolean is
Par : Node_Id;
+
begin
Par := Parent (V1);
while Nkind (Par) /= N_Full_Type_Declaration loop
if Par = V2 then
return True;
end if;
+
Par := Parent (Par);
end loop;
function Variant_Depth (N : Node_Id) return Integer is
Depth : Integer;
Par : Node_Id;
+
begin
Depth := 0;
Par := Parent (N);
while Nkind (Par) /= N_Full_Type_Declaration loop
Depth := Depth + 1;
- Par := Parent (Par);
+ Par := Parent (Par);
end loop;
return Depth;
end Variant_Depth;
- ------------------------
- -- Get_Component_Type --
- ------------------------
-
- function Get_Component_Type (Nam : Node_Id) return Entity_Id is
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
-
- while Present (Comp) loop
- if Chars (Comp) = Chars (Nam) then
- if Ekind (Comp) = E_Discriminant then
- Error_Msg_N ("delta cannot apply to discriminant", Nam);
- end if;
-
- return Etype (Comp);
- end if;
+ -- Local variables
- Comp := Next_Entity (Comp);
- end loop;
+ Deltas : constant List_Id := Component_Associations (N);
- Error_Msg_NE ("type& has no component with this name", Nam, Typ);
- return Any_Type;
- end Get_Component_Type;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id;
-- Start of processing for Resolve_Delta_Record_Aggregate
begin
- Variant := Empty;
Assoc := First (Deltas);
-
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Comp_Type := Get_Component_Type (Choice);
+
if Comp_Type /= Any_Type then
Check_Variant (Choice);
end if;
-- this is the result of some kind of previous error generating a
-- junk identifier.
- if not Is_Valid_Name (Chars (N))
- and then Total_Errors_Detected /= 0
- then
+ if not Is_Valid_Name (Chars (N)) and then Total_Errors_Detected /= 0 then
return;
else
Find_Direct_Name (N);
-- Analyze_Aggregate --
-----------------------
- -- Most of the analysis of Aggregates requires that the type be known,
- -- and is therefore put off until resolution of the context.
- -- Delta aggregates have a base component that determines the type of the
- -- enclosing aggregate so its type can be ascertained earlier. This also
- -- allows delta aggregates to appear in the context of a record type with
- -- a private extension, as per the latest update of AI12-0127.
+ -- Most of the analysis of Aggregates requires that the type be known, and
+ -- is therefore put off until resolution of the context. Delta aggregates
+ -- have a base component that determines the enclosing aggregate type so
+ -- its type can be ascertained earlier. This also allows delta aggregates
+ -- to appear in the context of a record type with a private extension, as
+ -- per the latest update of AI12-0127.
procedure Analyze_Aggregate (N : Node_Id) is
begin
if Nkind (N) = N_Delta_Aggregate then
declare
Base : constant Node_Id := Expression (N);
+
I : Interp_Index;
It : Interp;
begin
Analyze (Base);
- -- If the base is overloaded, propagate interpretations
- -- to the enclosing aggregate.
+ -- If the base is overloaded, propagate interpretations to the
+ -- enclosing aggregate.
if Is_Overloaded (Base) then
Get_First_Interp (Base, I, It);
and then Present (Limited_View (Scope (Etype (N))))
and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N))))
then
- Error_Msg_NE ("cannot call function that returns "
- & "limited view of}", N, Etype (N));
Error_Msg_NE
- ("\there must be a regular with_clause for package& "
- & "in the current unit, or in some unit in its context",
- N, Scope (Etype (N)));
+ ("cannot call function that returns limited view of}",
+ N, Etype (N));
+
+ Error_Msg_NE
+ ("\there must be a regular with_clause for package & in the "
+ & "current unit, or in some unit in its context",
+ N, Scope (Etype (N)));
+
Set_Etype (N, Any_Type);
end if;
end if;
Pragma_Remote_Types => False,
Pragma_Shared_Passive => False,
Pragma_Task_Dispatching_Policy => False,
+ Pragma_Unmodified => False,
+ Pragma_Unreferenced => False,
Pragma_Warnings => False,
others => True);
elsif Nkind_In (N, N_Case_Expression,
N_Character_Literal,
- N_If_Expression,
- N_Delta_Aggregate)
+ N_Delta_Aggregate,
+ N_If_Expression)
then
Set_Etype (N, Expr_Type);
-- user about it here.
if Ekind (Typ) = E_Anonymous_Access_Type
- and then Is_Controlled_Active (Desig_T)
+ and then Is_Controlled_Active (Desig_T)
then
- Error_Msg_N ("??anonymous access-to-controlled object will "
- & "be finalized when its enclosing unit goes out "
- & "of scope", N);
+ Error_Msg_N
+ ("??anonymous access-to-controlled object will be finalized "
+ & "when its enclosing unit goes out of scope", N);
end if;
end if;
end if;
elsif Ekind (E) = E_Generic_Function then
Error_Msg_N ("illegal use of generic function", N);
- -- In Ada 83 an OUT parameter cannot be read
+ -- In Ada 83 an OUT parameter cannot be read, but attributes of
+ -- array types (i.e. bounds and length) are legal.
elsif Ekind (E) = E_Out_Parameter
+ and then (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Is_Scalar_Type (Etype (E)))
+
and then (Nkind (Parent (N)) in N_Op
or else Nkind (Parent (N)) = N_Explicit_Dereference
or else Is_Assignment_Or_Object_Expression
-- The tree contains not only the full syntactic representation of the
-- program, but also the results of semantic analysis. In particular, the
--- nodes for defining identifiers, defining character literals and defining
+-- nodes for defining identifiers, defining character literals, and defining
-- operator symbols, collectively referred to as entities, represent what
-- would normally be regarded as the symbol table information. In addition a
-- number of the tree nodes contain semantic information.
-- The Present function tests for Empty, which in this case signals the end
-- of the list. First returns Empty immediately if the list is empty.
- -- Present is defined in Atree, First and Next are defined in Nlists.
+ -- Present is defined in Atree; First and Next are defined in Nlists.
-- The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all
-- contexts, which is handled as described in the previous section, and
-- In the following node definitions, all fields, both syntactic and
-- semantic, are documented. The one exception is in the case of entities
- -- (defining identifiers, character literals and operator symbols), where
+ -- (defining identifiers, character literals, and operator symbols), where
-- the usage of the fields depends on the entity kind. Entity fields are
-- fully documented in the separate package Einfo.
-- complete a subprogram declaration.
-- Corresponding_Spec_Of_Stub (Node2-Sem)
- -- This field is present in subprogram, package, task and protected body
+ -- This field is present in subprogram, package, task, and protected body
-- stubs where it points to the corresponding spec of the stub. Due to
-- clashes in the structure of nodes, we cannot use Corresponding_Spec.
-- Is_Generic_Contract_Pragma (Flag2-Sem)
-- This flag is present in N_Pragma nodes. It is set when the pragma is
- -- a source construct, applies to a generic unit or its body and denotes
+ -- a source construct, applies to a generic unit or its body, and denotes
-- one of the following contract-related annotations:
-- Abstract_State
-- Contract_Cases
-- nodes which emulate the body of a task unit.
-- Is_Task_Master (Flag5-Sem)
- -- A flag set in a Subprogram_Body, Block_Statement or Task_Body node to
+ -- A flag set in a Subprogram_Body, Block_Statement, or Task_Body node to
-- indicate that the construct is a task master (i.e. has declared tasks
-- or declares an access to a task type).
-- calls to Freeze_Expression.
-- Next_Entity (Node2-Sem)
- -- Present in defining identifiers, defining character literals and
+ -- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope are chained, and this field is used as the forward pointer for
-- this list. See Einfo for further details.
-- because Analyze wants to insert extra actions on this list.
-- Rounded_Result (Flag18-Sem)
- -- Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes.
+ -- Present in N_Type_Conversion, N_Op_Divide, and N_Op_Multiply nodes.
-- Used in the fixed-point cases to indicate that the result must be
-- rounded as a result of the use of the 'Round attribute. Also used for
-- integer N_Op_Divide nodes to indicate that the result should be
-- operation named (statically) in a dispatching call.
-- Scope (Node3-Sem)
- -- Present in defining identifiers, defining character literals and
+ -- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope all use this field to reference the corresponding scope entity.
-- See Einfo for further details.
-- always set to No_List.
-- Treat_Fixed_As_Integer (Flag14-Sem)
- -- This flag appears in operator nodes for divide, multiply, mod and rem
+ -- This flag appears in operator nodes for divide, multiply, mod, and rem
-- on fixed-point operands. It indicates that the operands are to be
-- treated as integer values, ignoring small values. This flag is only
-- set as a result of expansion of fixed-point operations. Typically a
-- pain to allow these aspects to pervade the pragma syntax, and the
-- representation of pragma nodes internally. So what we do is to
-- replace these ASPECT_MARK forms with identifiers whose name is one
- -- of the special internal names _Pre, _Post or _Type_Invariant.
+ -- of the special internal names _Pre, _Post, or _Type_Invariant.
-- We do a similar replacement of these Aspect_Mark forms in the
-- Expression of a pragma argument association for the cases of
-- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
- -- Note: ABSTRACT, LIMITED and record extension part are not permitted
- -- in Ada 83 mode
+ -- Note: ABSTRACT, LIMITED, and record extension part are not permitted
+ -- in Ada 83 mode.
-- Note: a record extension part is required if ABSTRACT is present
-- Subtype_Indication field or else the Access_Definition field.
-- N_Component_Definition
- -- Sloc points to ALIASED, ACCESS or to first token of subtype mark
+ -- Sloc points to ALIASED, ACCESS, or to first token of subtype mark
-- Aliased_Present (Flag4)
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5) (set to Empty if not present)
-- end record
-- | null record
- -- Note: the Abstract_Present, Tagged_Present and Limited_Present
+ -- Note: the Abstract_Present, Tagged_Present, and Limited_Present
-- flags appear only for a record definition appearing in a record
-- type definition.
-- Instead the Attribute_Name and Expressions fields of the parent
-- node (N_Attribute_Reference node) hold the information.
- -- Note: if ACCESS, DELTA or DIGITS appears in an attribute
+ -- Note: if ACCESS, DELTA, or DIGITS appears in an attribute
-- designator, then they are treated as identifiers internally
-- rather than the keywords of the same name.
-- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
-- list is in LIFO fashion.
- -- Classifications contains pragmas that either declare, categorize or
+ -- Classifications contains pragmas that either declare, categorize, or
-- establish dependencies between subprogram or package inputs and
-- outputs. Currently the following pragmas appear in this list:
-- Abstract_States
4 => False, -- unused
5 => False), -- unused
- -- Entries for Empty, Error and Unused. Even thought these have a Chars
+ -- Entries for Empty, Error, and Unused. Even though these have a Chars
-- field for debugging purposes, they are not really syntactic fields, so
-- we mark all fields as unused.
+2017-11-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/unreferenced.adb: New testcase.
+
+2017-11-09 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/out_param.adb: New testcase.
+
2017-11-09 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/elab3.adb, gnat.dg/elab3.ads, gnat.dg/elab3_pkg.adb,
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnat83" }
+
+procedure Out_Param
+ (Source : in String; Dest : out String; Char_Count : out Natural) is
+begin
+ --| Logic_Step:
+ --| Copy string Source to string Dest
+ Dest := (others => ' ');
+ Char_Count := 0;
+ if Source'Length > 0 and then Dest'Length > 0 then
+ if Source'Length > Dest'Length then
+ Char_Count := Dest'Length;
+ else
+ Dest (Dest'First .. (Dest'First + Source'Length - 1)) := Source;
+ Char_Count := Source'Length;
+ end if;
+ else
+ null;
+ end if;
+end Out_Param;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatd.F" }
+
+procedure Unreferenced is
+ X : aliased Integer;
+ Y : access Integer := X'Access;
+ Z : Integer renames Y.all;
+ pragma Unreferenced (Z);
+begin
+ null;
+end Unreferenced;
projects / gcc.git / commitdiff