Error_Msg_Qual_Level := 0;
end if;
+ -- Ada 2005 (AI-326): Check wrong use of tag incomplete
+ -- types with unknown discriminants. For example:
+
+ -- type T (<>) is tagged;
+ -- procedure P (X : access T); -- ERROR
+ -- procedure P (X : T); -- ERROR
+
+ if not From_With_Type (F_Type) then
+ if Is_Access_Type (F_Type) then
+ F_Type := Designated_Type (F_Type);
+ end if;
+
+ if Ekind (F_Type) = E_Incomplete_Type
+ and then Is_Tagged_Type (F_Type)
+ and then not Is_Class_Wide_Type (F_Type)
+ and then No (Full_View (F_Type))
+ and then Unknown_Discriminants_Present
+ (Parent (F_Type))
+ and then No (Stored_Constraint (F_Type))
+ then
+ Error_Msg_N
+ ("(Ada 2005): invalid use of unconstrained tagged"
+ & " incomplete type", E);
+ end if;
+ end if;
+
Next_Formal (Formal);
end loop;
Error_Msg_N
("?foreign convention function& should not " &
"return unconstrained array", E);
+
+ -- Ada 2005 (AI-326): Check wrong use of tagged
+ -- incomplete type
+ --
+ -- type T is tagged;
+ -- function F (X : Boolean) return T; -- ERROR
+
+ elsif Ekind (Etype (E)) = E_Incomplete_Type
+ and then Is_Tagged_Type (Etype (E))
+ and then No (Full_View (Etype (E)))
+ then
+ Error_Msg_N
+ ("(Ada 2005): invalid use of tagged incomplete type",
+ E);
end if;
end if;
end;
Freeze_Subprogram (E);
+ -- AI-326: Check wrong use of tag incomplete type
+ --
+ -- type T is tagged;
+ -- type Acc is access function (X : T) return T; -- ERROR
+
+ if Ekind (Etype (E)) = E_Incomplete_Type
+ and then Is_Tagged_Type (Etype (E))
+ and then No (Full_View (Etype (E)))
+ then
+ Error_Msg_N
+ ("(Ada 2005): invalid use of tagged incomplete type", E);
+ end if;
+
-- For access to a protected subprogram, freeze the equivalent
-- type (however this is not set if we are not generating code)
-- or if this is an anonymous type used just for resolution).
- elsif Ekind (E) = E_Access_Protected_Subprogram_Type
- and then Operating_Mode = Generate_Code
- and then Present (Equivalent_Type (E))
- then
- Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ elsif Ekind (E) = E_Access_Protected_Subprogram_Type then
+
+ -- AI-326: Check wrong use of tagged incomplete types
+
+ -- type T is tagged;
+ -- type As3D is access protected
+ -- function (X : Float) return T; -- ERROR
+
+ declare
+ Etyp : Entity_Id;
+
+ begin
+ Etyp := Etype (Directly_Designated_Type (E));
+
+ if Is_Class_Wide_Type (Etyp) then
+ Etyp := Etype (Etyp);
+ end if;
+
+ if Ekind (Etyp) = E_Incomplete_Type
+ and then Is_Tagged_Type (Etyp)
+ and then No (Full_View (Etyp))
+ then
+ Error_Msg_N
+ ("(Ada 2005): invalid use of tagged incomplete type", E);
+ end if;
+ end;
+
+ if Operating_Mode = Generate_Code
+ and then Present (Equivalent_Type (E))
+ then
+ Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ end if;
end if;
-- Generic types are never seen by the back-end, and are also not
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
--- by RM section rather than alphabetical
+-- by RM section rather than alphabetical.
with Sinfo.CN; use Sinfo.CN;
-- | CONCURRENT_TYPE_DECLARATION
-- INCOMPLETE_TYPE_DECLARATION ::=
- -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED];
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
when Tok_Tagged =>
Scan; -- past TAGGED
+ -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
+ -- is a tagged incomplete type.
+
+ if Ada_Version >= Ada_05
+ and then Token = Tok_Semicolon
+ then
+ Scan; -- past ;
+
+ Decl_Node :=
+ New_Node (N_Incomplete_Type_Declaration, Type_Loc);
+ Set_Defining_Identifier (Decl_Node, Ident_Node);
+ Set_Tagged_Present (Decl_Node);
+ Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
+ Set_Discriminant_Specifications (Decl_Node, Discr_List);
+
+ return Decl_Node;
+ end if;
+
if Token = Tok_Abstract then
Error_Msg_SC ("ABSTRACT must come before TAGGED");
Abstract_Present := True;
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- -- Access definition (AI-406) or subtype indication.
+ -- Access definition (AI-406) or subtype indication
if Token = Tok_Access then
if Ada_Version < Ada_05 then
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
- -- Object declaration with access definition, or renaming.
+ -- Object declaration with access definition, or renaming
if Token /= Tok_Renames then
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
SIS_Entry_Active := False;
- -- Test for assorted illegal declarations not diagnosed elsewhere.
+ -- Test for assorted illegal declarations not diagnosed elsewhere
Decl := First (Decls);
-------------------------------
procedure Check_Not_Incomplete_Type is
+ E : Entity_Id;
+ Typ : Entity_Id;
+
begin
+ -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
+ -- dereference we have to check wrong uses of incomplete types
+ -- (other wrong uses are checked at their freezing point).
+
+ -- Example 1: Limited-with
+
+ -- limited with Pkg;
+ -- package P is
+ -- type Acc is access Pkg.T;
+ -- X : Acc;
+ -- S : Integer := X.all'Size; -- ERROR
+ -- end P;
+
+ -- Example 2: Tagged incomplete
+
+ -- type T is tagged;
+ -- type Acc is access all T;
+ -- X : Acc;
+ -- S : constant Integer := X.all'Size; -- ERROR
+ -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
+
+ if Ada_Version >= Ada_05
+ and then Nkind (P) = N_Explicit_Dereference
+ then
+ E := P;
+ while Nkind (E) = N_Explicit_Dereference loop
+ E := Prefix (E);
+ end loop;
+
+ if From_With_Type (Etype (E)) then
+ Error_Attr
+ ("prefix of % attribute cannot be an incomplete type", P);
+
+ else
+ if Is_Access_Type (Etype (E)) then
+ Typ := Directly_Designated_Type (Etype (E));
+ else
+ Typ := Etype (E);
+ end if;
+
+ if Ekind (Typ) = E_Incomplete_Type
+ and then not Present (Full_View (Typ))
+ then
+ Error_Attr
+ ("prefix of % attribute cannot be an incomplete type", P);
+ end if;
+ end if;
+ end if;
+
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
or else In_Default_Expression
then
return;
-
else
Check_Fully_Declared (P_Type, P);
end if;
Init_Size_Align (T);
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
+
+ -- Ada 2005 (AI-326): Mininum decoration to give support to tagged
+ -- incomplete types
+
+ if Tagged_Present (N) then
+ Set_Is_Tagged_Type (T);
+ Make_Class_Wide_Type (T);
+ Set_Primitive_Operations (T, New_Elmt_List);
+ end if;
+
New_Scope (T);
Set_Stored_Constraint (T, No_Elist);
while Present (I) loop
- -- Protect against wrong usages. Example:
+ -- Protect against wrong uses. For example:
-- type I is interface;
-- type O is tagged null record;
- -- type Wrong is new I and O with null record;
+ -- type Wrong is new I and O with null record; -- ERROR
if Is_Interface (Etype (I)) then
H : Entity_Id;
begin
- -- If there is a previous partial view, no need to create a new one.
+ -- If there is a previous partial view, no need to create a new one
if Prev /= T then
return;
-- to avoid scoping issues in the back-end.
T1 := Etype (Lhs);
+
+ -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
+ -- type. For example:
+
+ -- limited with P;
+ -- package Pkg is
+ -- type Acc is access P.T;
+ -- end Pkg;
+
+ -- with Pkg; use Acc;
+ -- procedure Example is
+ -- A, B : Acc;
+ -- begin
+ -- A.all := B.all; -- ERROR
+ -- end Example;
+
+ if Nkind (Lhs) = N_Explicit_Dereference
+ and then Ekind (T1) = E_Incomplete_Type
+ then
+ Error_Msg_N ("invalid use of incomplete type", Lhs);
+ return;
+ end if;
+
Set_Assignment_Type (Lhs, T1);
Resolve (Rhs, T1);
return;
end if;
+ -- Ada 2005 (AI-326): In case of explicit dereference of incomplete
+ -- types, use the non-limited view if available
+
+ if Nkind (Rhs) = N_Explicit_Dereference
+ and then Ekind (T2) = E_Incomplete_Type
+ and then Is_Tagged_Type (T2)
+ and then Present (Non_Limited_View (T2))
+ then
+ T2 := Non_Limited_View (T2);
+ end if;
+
Set_Assignment_Type (Rhs, T2);
if Total_Errors_Detected /= 0 then
begin
Unblocked_Exit_Count := 0;
Exp := Expression (N);
- Analyze_And_Resolve (Exp, Any_Discrete);
+ Analyze (Exp);
+
+ -- The expression must be of any discrete type. In rare cases, the
+ -- expander constructs a case statement whose expression has a private
+ -- type whose full view is discrete. This can happen when generating
+ -- a stream operation for a variant type after the type is frozen,
+ -- when the partial of view of the type of the discriminant is private.
+ -- In that case, use the full view to analyze case alternatives.
+
+ if not Is_Overloaded (Exp)
+ and then not Comes_From_Source (N)
+ and then Is_Private_Type (Etype (Exp))
+ and then Present (Full_View (Etype (Exp)))
+ and then Is_Discrete_Type (Full_View (Etype (Exp)))
+ then
+ Resolve (Exp, Etype (Exp));
+ Exp_Type := Full_View (Etype (Exp));
+
+ else
+ Analyze_And_Resolve (Exp, Any_Discrete);
+ Exp_Type := Etype (Exp);
+ end if;
+
Check_Unset_Reference (Exp);
- Exp_Type := Etype (Exp);
Exp_Btype := Base_Type (Exp_Type);
-- The expression must be of a discrete type which must be determinable
-- assignment statements block to capture the bounds and perform
-- required finalization actions in case a bound includes a function
-- call that uses the temporary stack. We first pre-analyze a copy of
- -- the range in order to determine the expected type, and analyze
- -- and resolve the original bounds.
+ -- the range in order to determine the expected type, and analyze and
+ -- resolve the original bounds.
procedure Check_Controlled_Array_Attribute (DS : Node_Id);
-- If the bounds are given by a 'Range reference on a function call
Decl : Node_Id;
begin
- -- If the bound is a constant or an object, no need for a
- -- separate declaration. If the bound is the result of previous
- -- expansion it is already analyzed and should not be modified.
- -- Note that the Bound will be resolved later, if needed, as
- -- part of the call to Make_Index (literal bounds may need to
- -- be resolved to type Integer).
+ -- If the bound is a constant or an object, no need for a separate
+ -- declaration. If the bound is the result of previous expansion
+ -- it is already analyzed and should not be modified. Note that
+ -- the Bound will be resolved later, if needed, as part of the
+ -- call to Make_Index (literal bounds may need to be resolved to
+ -- type Integer).
if Analyzed (Original_Bound) then
return Original_Bound;
and then Ekind (Root_Type (Formal_Type)) =
E_Incomplete_Type)
then
- -- Ada 2005 (AI-50217): Incomplete tagged types that are made
- -- visible by a limited with_clause are valid formal types.
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed
- if From_With_Type (Formal_Type)
- and then Is_Tagged_Type (Formal_Type)
- then
+ if Is_Tagged_Type (Formal_Type) then
null;
elsif Nkind (Parent (T)) /= N_Access_Function_Definition
-- Ada 2005 (AI-231): Create and decorate an internal subtype
-- declaration corresponding to the null-excluding type of the
- -- formal in the enclosing scope. Finally, replace the
- -- parameter type of the formal with the internal subtype.
+ -- formal in the enclosing scope. Finally, replace the parameter
+ -- type of the formal with the internal subtype.
if Null_Exclusion_Present (Param_Spec) then
declare
Analyze_Per_Use_Expression (Default, Formal_Type);
- -- Check that the designated type of an access parameter's
- -- default is not a class-wide type unless the parameter's
- -- designated type is also class-wide.
+ -- Check that the designated type of an access parameter's default
+ -- is not a class-wide type unless the parameter's designated type
+ -- is also class-wide.
if Ekind (Formal_Type) = E_Anonymous_Access_Type
+ and then not From_With_Type (Formal_Type)
and then Is_Class_Wide_Default (Default)
and then not Is_Class_Wide_Type (Designated_Type (Formal_Type))
then
elsif Is_Array_Type (T) then
AS_Needed := True;
- -- The only other case which needs an actual subtype is an
- -- unconstrained record type which is an IN parameter (we cannot
- -- generate actual subtypes for the OUT or IN OUT case, since an
- -- assignment can change the discriminant values. However we exclude
- -- the case of initialization procedures, since discriminants are
- -- handled very specially in this context, see the section entitled
- -- "Handling of Discriminants" in Einfo. We also exclude the case of
- -- Discrim_SO_Functions (functions used in front end layout mode for
- -- size/offset values), since in such functions only discriminants
- -- are referenced, and not only are such subtypes not needed, but
- -- they cannot always be generated, because of order of elaboration
- -- issues.
+ -- The only other case needing an actual subtype is an unconstrained
+ -- record type which is an IN parameter (we cannot generate actual
+ -- subtypes for the OUT or IN OUT case, since an assignment can
+ -- change the discriminant values. However we exclude the case of
+ -- initialization procedures, since discriminants are handled very
+ -- specially in this context, see the section entitled "Handling of
+ -- Discriminants" in Einfo.
+
+ -- We also exclude the case of Discrim_SO_Functions (functions used
+ -- in front end layout mode for size/offset values), since in such
+ -- functions only discriminants are referenced, and not only are such
+ -- subtypes not needed, but they cannot always be generated, because
+ -- of order of elaboration issues.
elsif Is_Record_Type (T)
and then Ekind (Formal) = E_In_Parameter
and then Ekind (Entity (Prefix (N))) = E_In_Parameter
then
null;
+
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
+ -- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_
+ -- Object_Renaming, and Freeze_Entity.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Entity_Name (Prefix (N))
+ and then Ekind (Directly_Designated_Type (Etype (Prefix (N))))
+ = E_Incomplete_Type
+ and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
+ then
+ null;
+
else
Check_Fully_Declared (Typ, N);
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_With_Type_Clause);
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
+ or else NT (N).Nkind = N_Incomplete_Type_Declaration
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_With_Type_Clause);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-----------------------------------------
-- INCOMPLETE_TYPE_DECLARATION ::=
- -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED];
-- N_Incomplete_Type_Declaration
-- Sloc points to TYPE
-- discriminant part, or if the discriminant part is an
-- unknown discriminant part)
-- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+ -- Tagged_Present (Flag15)
----------------------------
-- 3.11 Declarative Part --
-- parent library unit package name is present.
-- Identifier (Node1)
- -- Note that the identifier can also be an operator symbol here.
+ -- Note that the identifier can also be an operator symbol here
------------------------------
-- 6.1 Defining Designator --
-- HANDLED_SEQUENCE_OF_STATEMENTS
-- end [task_IDENTIFIER];
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Task_Body
-- Sloc points to TASK
-- Note: protected bodies are not allowed in Ada 83 mode
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Protected_Body
-- Sloc points to PROTECTED
-- HANDLED_SEQUENCE_OF_STATEMENTS
-- end [entry_IDENTIFIER]];
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- Note: there are no explicit declarations allowed in an accept
-- statement. However, the implicit declarations for any statement
-- the ENTRY_BODY_FORMAL_PART to avoid the N_Entry_Body node getting
-- too full (it would otherwise have too many fields)
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Entry_Body
-- Sloc points to ENTRY
-- formal part itself. Also this means that the barrier condition
-- always has somewhere to be stored.
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Entry_Body_Formal_Part
-- Sloc points to first token
-- ENTRY_INDEX_SPECIFICATION ::=
-- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Entry_Index_Specification
-- Sloc points to FOR
-- The parser may generate a procedure call for this construct. The
-- semantic pass must correct this misidentification where needed.
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Entry_Call_Statement
-- Sloc points to first token of name
-- Note: requeue statements are not permitted in Ada 83 mode
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Requeue_Statement
-- Sloc points to REQUEUE
-- Note: delay until statements are not permitted in Ada 83 mode
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Delay_Until_Statement
-- Sloc points to DELAY
-- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Delay_Relative_Statement
-- Sloc points to DELAY
-- SEQUENCE_OF_STATEMENTS]
-- end select;
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- Note: the guard expression, if present, appears in the node for
-- the select alternative.
-- ACCEPT_ALTERNATIVE ::=
-- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Accept_Alternative
-- Sloc points to ACCEPT
-- DELAY_ALTERNATIVE ::=
-- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Delay_Alternative
-- Sloc points to DELAY
-- TERMINATE_ALTERNATIVE ::= terminate;
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Terminate_Alternative
-- Sloc points to TERMINATE
-- DELAY_ALTERNATIVE
-- end select;
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Timed_Entry_Call
-- Sloc points to SELECT
-- ENTRY_CALL_ALTERNATIVE ::=
-- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Entry_Call_Alternative
-- Sloc points to first token of entry call statement
-- SEQUENCE_OF_STATEMENTS
-- end select;
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Conditional_Entry_Call
-- Sloc points to SELECT
-- Note: asynchronous select is not permitted in Ada 83 mode
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Asynchronous_Select
-- Sloc points to SELECT
-- TRIGGERING_ALTERNATIVE ::=
-- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Triggering_Alternative
-- Sloc points to first token of triggering statement
-- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Abortable_Part
-- Sloc points to ABORT
-- ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
- -- Gigi restriction: This node never appears.
+ -- Gigi restriction: This node never appears
-- N_Abort_Statement
-- Sloc points to ABORT
-- is true even in the case of an accept statement (see description of
-- the N_Accept_Statement node).
- -- End_Label refers to the containing construct.
+ -- End_Label refers to the containing construct
-----------------------------
-- 11.2 Exception Handler --
-- an expanded name node to a selected component node to be done
-- easily, see Sinfo.CN.Change_Selected_Component_To_Expanded_Name.
- -- There is no special sprint syntax for an expanded name.
+ -- There is no special sprint syntax for an expanded name
-- N_Expanded_Name
-- Sloc points to the period
-- with all checks off, regardless of the current setting of scope
-- suppress flags.
- -- Sprint syntax: `(expression).
+ -- Sprint syntax: `(expression)
-- Note: this node is always removed from the tree (and replaced by
-- its constituent expression) on completion of analysis, so it only
-- clearly a function call to an instantiation of Unchecked_Conversion
-- is not a variable in any case.
- -- Sprint syntax: subtype-mark!(expression).
+ -- Sprint syntax: subtype-mark!(expression)
-- N_Unchecked_Type_Conversion
-- Sloc points to related node in source