+2015-01-30 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_attr.adb (Declared_Within_Generic_Unit):
+ New function to test whether an entity is declared within the
+ declarative region of a given generic unit.
+ (Resolve_Attribute): For checking legality of subprogram'Access within
+ a generic unit, call new Boolean function Declared_Within_Generic_Unit
+ instead of simply comparing the results of Enclosing_Generic_Unit on
+ the prefix and access type. Correct minor comment typos.
+
+2015-01-30 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb, exp_util.ads: Update comment.
+ * exp_util.adb, exp_ch3.adb: Minor code reorganization and reformatting.
+ * sem_util.adb: Minor: fix typo.
+
2015-01-30 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.adb (Analyze_Attribute): Ensure that
or else Frontend_Layout_On_Target
then
Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
+
Decl :=
First_Non_Pragma (Component_Items (Component_List_Node));
-
while Present (Decl) loop
Set_Discriminant_Checking_Func
(Defining_Identifier (Decl), Func_Id);
-
Next_Non_Pragma (Decl);
end loop;
return Empty_List;
end if;
- Full_Type := Typ;
-
-- Use the [underlying] full view when dealing with a private type. This
-- may require several steps depending on derivations.
+ Full_Type := Typ;
loop
if Is_Private_Type (Full_Type) then
if Present (Full_View (Full_Type)) then
if Has_Discriminants (Full_Init_Type) then
Discr := First_Discriminant (Full_Init_Type);
-
while Present (Discr) loop
-- If this is a discriminated concurrent type, the init_proc
declare
Parent_IP : constant Name_Id :=
Make_Init_Proc_Name (Etype (Rec_Ent));
- Stmt : Node_Id := First (Stmts);
- IP_Call : Node_Id := Empty;
+ Stmt : Node_Id;
+ IP_Call : Node_Id;
IP_Stmts : List_Id;
begin
-- Look for a call to the parent IP at the beginning
-- of Stmts associated with the record extension
+ Stmt := First (Stmts);
+ IP_Call := Empty;
while Present (Stmt) loop
if Nkind (Stmt) = N_Procedure_Call_Statement
and then Chars (Name (Stmt)) = Parent_IP
end if;
S := First (Constraints (C));
-
while Present (S) loop
Number_Of_Constraints := Number_Of_Constraints + 1;
Next (S);
Set_Itype (Ref, Etype (First_Index (Typ)));
Append_Freeze_Action (Rec_Type, Ref);
- Sub_Aggr := First (Expressions (Comp));
-
-- Recurse on nested arrays
+ Sub_Aggr := First (Expressions (Comp));
while Present (Sub_Aggr) loop
Collect_Itypes (Sub_Aggr);
Next (Sub_Aggr);
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
if Nkind (Decl) = N_Component_Declaration then
- Id := Defining_Identifier (Decl);
+ Id := Defining_Identifier (Decl);
if Has_Invariants (Etype (Id))
and then In_Open_Scopes (Scope (R_Type))
---------------------
function Is_C_Derivation (Typ : Entity_Id) return Boolean is
- T : Entity_Id := Typ;
+ T : Entity_Id;
begin
+ T := Typ;
loop
if Is_CPP_Class (T)
or else Convention (T) = Convention_C
elsif Needs_Finalization (Desig_Type)
or else (Is_Incomplete_Type (Desig_Type)
- and then No (Full_View (Desig_Type)))
+ and then No (Full_View (Desig_Type)))
then
Build_Finalization_Master (Def_Id);
Body_List := New_List;
Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
-
while Present (Prim_Elmt) loop
Subp := Node (Prim_Elmt);
if Is_Untagged_Derivation (Typ) then
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
-- class-wide).
function Finalize_Address (Typ : Entity_Id) return Entity_Id;
- -- Locate TSS primitive Finalize_Address in type Typ
+ -- Locate TSS primitive Finalize_Address in type Typ. Return Empty if the
+ -- subprogram is not available.
function Find_Interface_ADT
(T : Entity_Id;
end;
end if;
+ -- Historical note: We used to create a finalization master for an
+ -- access type whose designated type is not controlled, but contains
+ -- private controlled compoments. This form of post processing is no
+ -- longer needed because the finalization master is now created when
+ -- the access type is frozen (see Exp_Ch3.Freeze_Type).
+
Next_Entity (E);
end loop;
end Freeze_All;
-- Error, or warning within an instance, if the static accessibility
-- rules of 3.10.2 are violated.
+ function Declared_Within_Generic_Unit
+ (Entity : Entity_Id;
+ Generic_Unit : Node_Id) return Boolean;
+ -- Returns True if Declared_Entity is declared within the declarative
+ -- region of Generic_Unit; otherwise returns False.
+
---------------------------
-- Accessibility_Message --
---------------------------
end if;
end Accessibility_Message;
+ ----------------------------------
+ -- Declared_Within_Generic_Unit --
+ ----------------------------------
+
+ function Declared_Within_Generic_Unit
+ (Entity : Entity_Id;
+ Generic_Unit : Node_Id) return Boolean
+ is
+ Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity);
+
+ begin
+ while Present (Generic_Encloser) loop
+ if Generic_Encloser = Generic_Unit then
+ return True;
+ end if;
+
+ -- We have to step to the scope of the generic's entity, because
+ -- otherwise we'll just get back the same generic.
+
+ Generic_Encloser :=
+ Enclosing_Generic_Unit
+ (Scope (Defining_Entity (Generic_Encloser)));
+ end loop;
+
+ return False;
+ end Declared_Within_Generic_Unit;
+
-- Start of processing for Resolve_Attribute
begin
-- level of the actual type is not known). This restriction
-- does not apply when the attribute type is an anonymous
-- access-to-subprogram type. Note that this check was
- -- revised by AI-229, because the originally Ada 95 rule
+ -- revised by AI-229, because the original Ada 95 rule
-- was too lax. The original rule only applied when the
-- subprogram was declared within the body of the generic,
-- which allowed the possibility of dangling references).
- -- The rule was also too strict in some case, in that it
+ -- The rule was also too strict in some cases, in that it
-- didn't permit the access to be declared in the generic
-- spec, whereas the revised rule does (as long as it's not
-- a formal type).
then
-- The attribute type's ultimate ancestor must be
-- declared within the same generic unit as the
- -- subprogram is declared. The error message is
+ -- subprogram is declared (including within another
+ -- nested generic unit). The error message is
-- specialized to say "ancestor" for the case where the
-- access type is not its own ancestor, since saying
-- simply "access type" would be very confusing.
- if Enclosing_Generic_Unit (Entity (P)) /=
- Enclosing_Generic_Unit (Root_Type (Btyp))
+ if not Declared_Within_Generic_Unit
+ (Root_Type (Btyp),
+ Enclosing_Generic_Unit (Entity (P)))
then
Error_Msg_N
("''Access attribute not allowed in generic body",
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
projects / gcc.git / commitdiff