Index: freeze.adb =================================================================== --- freeze.adb (revision 128777) +++ freeze.adb (working copy) @@ -2542,15 +2542,13 @@ package body Freeze is -- Case of a type or subtype being frozen else - -- Check preelaborable initialization for full type completing a - -- private type for which pragma Preelaborable_Initialization given. - - if Must_Have_Preelab_Init (E) - and then not Has_Preelaborable_Initialization (E) - then - Error_Msg_N - ("full view of & does not have preelaborable initialization", E); - end if; + -- We used to check here that a full type must have preelaborable + -- initialization if it completes a private type specified with + -- pragma Preelaborable_Intialization, but that missed cases where + -- the types occur within a generic package, since the freezing + -- that occurs within a containing scope generally skips traversal + -- of a generic unit's declarations (those will be frozen within + -- instances). This check was moved to Analyze_Package_Specification. -- The type may be defined in a generic unit. This can occur when -- freezing a generic function that returns the type (which is Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 128777) +++ sem_ch7.adb (working copy) @@ -1168,15 +1168,27 @@ package body Sem_Ch7 is Set_First_Private_Entity (Id, Next_Entity (L)); end if; - -- Check rule of 3.6(11), which in general requires waiting till all - -- full types have been seen. - E := First_Entity (Id); while Present (E) loop + + -- Check rule of 3.6(11), which in general requires waiting till all + -- full types have been seen. + if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then Check_Aliased_Component_Types (E); end if; + -- Check preelaborable initialization for full type completing a + -- private type for which pragma Preelaborable_Initialization given. + + if Is_Type (E) + and then Must_Have_Preelab_Init (E) + and then not Has_Preelaborable_Initialization (E) + then + Error_Msg_N + ("full view of & does not have preelaborable initialization", E); + end if; + Next_Entity (E); end loop; @@ -2024,8 +2036,24 @@ package body Sem_Ch7 is Type_In_Use (Etype (Next_Formal (First_Formal (Id)))))); else - Set_Is_Potentially_Use_Visible (Id, - In_Use (P) and not Is_Hidden (Id)); + if In_Use (P) and then not Is_Hidden (Id) then + + -- A child unit of a use-visible package remains use-visible + -- only if it is itself a visible child unit. Otherwise it + -- would remain visible in other contexts where P is use- + -- visible, because once compiled it stays in the entity list + -- of its parent unit. + + if Is_Child_Unit (Id) then + Set_Is_Potentially_Use_Visible (Id, + Is_Visible_Child_Unit (Id)); + else + Set_Is_Potentially_Use_Visible (Id); + end if; + + else + Set_Is_Potentially_Use_Visible (Id, False); + end if; end if; -- Local entities are not immediately visible outside of the package Index: sem_util.adb =================================================================== --- sem_util.adb (revision 128777) +++ sem_util.adb (working copy) @@ -110,15 +110,14 @@ package body Sem_Util is if Present (Full_View (Typ)) then Nod := Type_Definition (Parent (Full_View (Typ))); - -- If the full-view is not available we cannot do anything - -- else here (the source has errors) + -- If the full-view is not available we cannot do anything else + -- here (the source has errors). else return Empty_List; end if; - -- The support for generic formals with interfaces is still - -- missing??? + -- Support for generic formals with interfaces is still missing ??? elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then return Empty_List; @@ -2677,6 +2676,64 @@ package body Sem_Util is raise Program_Error; end Find_Corresponding_Discriminant; + -------------------------- + -- Find_Overlaid_Object -- + -------------------------- + + function Find_Overlaid_Object (N : Node_Id) return Entity_Id is + Expr : Node_Id; + + begin + -- We are looking for one of the two following forms: + + -- for X'Address use Y'Address + + -- or + + -- Const : constant Address := expr; + -- ... + -- for X'Address use Const; + + -- In the second case, the expr is either Y'Address, or recursively a + -- constant that eventually references Y'Address. + + if Nkind (N) = N_Attribute_Definition_Clause + and then Chars (N) = Name_Address + then + -- This loop checks the form of the expression for Y'Address where Y + -- is an object entity name. The first loop checks the original + -- expression in the attribute definition clause. Subsequent loops + -- check referenced constants. + + Expr := Expression (N); + loop + -- Check for Y'Address where Y is an object entity + + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Is_Entity_Name (Prefix (Expr)) + and then Is_Object (Entity (Prefix (Expr))) + then + return Entity (Prefix (Expr)); + + -- Check for Const where Const is a constant entity + + elsif Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Expr := Constant_Value (Entity (Expr)); + + -- Anything else does not need checking + + else + exit; + end if; + end loop; + end if; + + return Empty; + end Find_Overlaid_Object; + -------------------------------------------- -- Find_Overridden_Synchronized_Primitive -- -------------------------------------------- @@ -4386,6 +4443,151 @@ package body Sem_Util is Ent : Entity_Id; Exp : Node_Id; + function Is_Preelaborable_Expression (N : Node_Id) return Boolean; + -- Returns True if and only if the expression denoted by N does not + -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). + + --------------------------------- + -- Is_Preelaborable_Expression -- + --------------------------------- + + function Is_Preelaborable_Expression (N : Node_Id) return Boolean is + Exp : Node_Id; + Assn : Node_Id; + Choice : Node_Id; + Comp_Type : Entity_Id; + Is_Array_Aggr : Boolean; + + begin + if Is_Static_Expression (N) then + return True; + + elsif Nkind (N) = N_Null then + return True; + + elsif Nkind (N) = N_Attribute_Reference + and then + (Attribute_Name (N) = Name_Access + or else + Attribute_Name (N) = Name_Unchecked_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + then + return True; + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Preelaborable_Expression (Expression (N)); + + -- For aggregates we have to check that each of the associations + -- is preelaborable. + + elsif Nkind (N) = N_Aggregate + or else Nkind (N) = N_Extension_Aggregate + then + Is_Array_Aggr := Is_Array_Type (Etype (N)); + + if Is_Array_Aggr then + Comp_Type := Component_Type (Etype (N)); + end if; + + -- Check the ancestor part of extension aggregates, which must + -- be either the name of a type that has preelaborable init or + -- an expression that is preelaborable. + + if Nkind (N) = N_Extension_Aggregate then + declare + Anc_Part : constant Node_Id := Ancestor_Part (N); + + begin + if Is_Entity_Name (Anc_Part) + and then Is_Type (Entity (Anc_Part)) + then + if not Has_Preelaborable_Initialization + (Entity (Anc_Part)) + then + return False; + end if; + + elsif not Is_Preelaborable_Expression (Anc_Part) then + return False; + end if; + end; + end if; + + -- Check positional associations + + Exp := First (Expressions (N)); + while Present (Exp) loop + if not Is_Preelaborable_Expression (Exp) then + return False; + end if; + + Next (Exp); + end loop; + + -- Check named associations + + Assn := First (Component_Associations (N)); + while Present (Assn) loop + Choice := First (Choices (Assn)); + while Present (Choice) loop + if Is_Array_Aggr then + if Nkind (Choice) = N_Others_Choice then + null; + + elsif Nkind (Choice) = N_Range then + if not Is_Static_Range (Choice) then + return False; + end if; + + elsif not Is_Static_Expression (Choice) then + return False; + end if; + + else + Comp_Type := Etype (Choice); + end if; + + Next (Choice); + end loop; + + -- If the association has a <> at this point, then we have + -- to check whether the component's type has preelaborable + -- initialization. Note that this only occurs when the + -- association's corresponding component does not have a + -- default expression, the latter case having already been + -- expanded as an expression for the association. + + if Box_Present (Assn) then + if not Has_Preelaborable_Initialization (Comp_Type) then + return False; + end if; + + -- In the expression case we check whether the expression + -- is preelaborable. + + elsif + not Is_Preelaborable_Expression (Expression (Assn)) + then + return False; + end if; + + Next (Assn); + end loop; + + -- If we get here then aggregate as a whole is preelaborable + + return True; + + -- All other cases are not preelaborable + + else + return False; + end if; + end Is_Preelaborable_Expression; + + -- Start of processing for Check_Components + begin -- Loop through entities of record or protected type @@ -4400,8 +4602,8 @@ package body Sem_Util is then -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and - -- tag fields are examples of such entitires. For these - -- cases, we just test the type of the entity. + -- tag fields are examples of such entitires. For these cases, + -- we just test the type of the entity. if Present (Declaration_Node (Ent)) then Exp := Expression (Declaration_Node (Ent)); @@ -4409,8 +4611,8 @@ package body Sem_Util is Exp := Empty; end if; - -- A component has PI if it has no default expression and - -- the component type has PI. + -- A component has PI if it has no default expression and the + -- component type has PI. if No (Exp) then if not Has_Preelaborable_Initialization (Etype (Ent)) then @@ -4418,29 +4620,9 @@ package body Sem_Util is exit; end if; - -- Or if expression obeys rules for preelaboration. For - -- now we approximate this by testing if the default - -- expression is a static expression or if it is an - -- access attribute reference, or the literal null. - - -- This is an approximation, it is probably incomplete??? - - elsif Is_Static_Expression (Exp) then - null; - - elsif Nkind (Exp) = N_Attribute_Reference - and then (Attribute_Name (Exp) = Name_Access - or else - Attribute_Name (Exp) = Name_Unchecked_Access - or else - Attribute_Name (Exp) = Name_Unrestricted_Access) - then - null; - - elsif Nkind (Exp) = N_Null then - null; + -- Require the default expression to be preelaborable - else + elsif not Is_Preelaborable_Expression (Exp) then Has_PE := False; exit; end if; @@ -4462,6 +4644,15 @@ package body Sem_Util is return True; end if; + -- If the type is a subtype representing a generic actual type, then + -- test whether its base type has preelaborable initialization since + -- the subtype representing the actual does not inherit this attribute + -- from the actual or formal. (but maybe it should???) + + if Is_Generic_Actual_Type (E) then + return Has_Preelaborable_Initialization (Base_Type (E)); + end if; + -- Other private types never have preelaborable initialization if Is_Private_Type (E) then @@ -4586,24 +4777,21 @@ package body Sem_Util is UT : constant Entity_Id := Underlying_Type (Btype); begin if No (UT) then - if No (Full_View (Btype)) then return not Is_Generic_Type (Btype) and then not Is_Generic_Type (Root_Type (Btype)); - else return not Is_Generic_Type (Root_Type (Full_View (Btype))); end if; - else return not Is_Frozen (UT) and then Has_Private_Component (UT); end if; end; + elsif Is_Array_Type (Btype) then return Has_Private_Component (Component_Type (Btype)); elsif Is_Record_Type (Btype) then - Component := First_Component (Btype); while Present (Component) loop if Has_Private_Component (Etype (Component)) then @@ -4716,7 +4904,6 @@ package body Sem_Util is or else Ekind (S) = E_Procedure) and then Is_Generic_Instance (S) then - -- A child instance is always compiled in the context of a parent -- instance. Nevertheless, the actuals are not analyzed in an -- instance context. We detect this case by examining the current @@ -4910,7 +5097,8 @@ package body Sem_Util is begin Save_Interps (N, New_Prefix); Rewrite (N, - Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); + Make_Explicit_Dereference (Sloc (N), + Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); @@ -4973,9 +5161,8 @@ package body Sem_Util is ------------------- function Is_AAMP_Float (E : Entity_Id) return Boolean is - begin pragma Assert (Is_Type (E)); - + begin return AAMP_On_Target and then Is_Floating_Point_Type (E) and then E = Base_Type (E); @@ -5072,8 +5259,8 @@ package body Sem_Util is ------------------------- function Is_Ancestor_Package - (E1 : Entity_Id; - E2 : Entity_Id) return Boolean + (E1 : Entity_Id; + E2 : Entity_Id) return Boolean is Par : Entity_Id; @@ -5104,6 +5291,10 @@ package body Sem_Util is function Is_Atomic_Prefix (N : Node_Id) return Boolean; -- If prefix is an implicit dereference, examine designated type + ---------------------- + -- Is_Atomic_Prefix -- + ---------------------- + function Is_Atomic_Prefix (N : Node_Id) return Boolean is begin if Is_Access_Type (Etype (N)) then @@ -5114,6 +5305,10 @@ package body Sem_Util is end if; end Is_Atomic_Prefix; + ---------------------------------- + -- Object_Has_Atomic_Components -- + ---------------------------------- + function Object_Has_Atomic_Components (N : Node_Id) return Boolean is begin if Has_Atomic_Components (Etype (N))