X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Ffreeze.adb;h=15bd6e075e3adfe2bc9e6735612a57831160ad55;hb=c0a208a52ba10b65d217c635ddddf7a07ea51ebd;hp=c8a31f059329493d0a0a272de09b6620278e4ae9;hpb=752dfce02cb1f476da04979af06ce8fcc725f58f;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c8a31f05932..15bd6e075e3 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- You should have received a copy of the GNU General Public License along -- --- with this program; see file COPYING3. If not see -- --- . -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -43,6 +42,7 @@ with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -101,10 +101,11 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id); -- Freezes Ent using Freeze_Entity, and appends the resulting list of - -- nodes to Result, modifying Result from No_List if necessary. + -- nodes to Result, modifying Result from No_List if necessary. N has + -- the same usage as in Freeze_Entity. procedure Freeze_Enumeration_Type (Typ : Entity_Id); -- Freeze enumeration type. The Esize field is set as processing @@ -138,20 +139,20 @@ package body Freeze is procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); - -- This procedure is called for each subprogram to complete processing - -- of default expressions at the point where all types are known to be - -- frozen. The expressions must be analyzed in full, to make sure that - -- all error processing is done (they have only been pre-analyzed). If - -- the expression is not an entity or literal, its analysis may generate - -- code which must not be executed. In that case we build a function - -- body to hold that code. This wrapper function serves no other purpose - -- (it used to be called to evaluate the default, but now the default is - -- inlined at each point of call). + -- This procedure is called for each subprogram to complete processing of + -- default expressions at the point where all types are known to be frozen. + -- The expressions must be analyzed in full, to make sure that all error + -- processing is done (they have only been pre-analyzed). If the expression + -- is not an entity or literal, its analysis may generate code which must + -- not be executed. In that case we build a function body to hold that + -- code. This wrapper function serves no other purpose (it used to be + -- called to evaluate the default, but now the default is inlined at each + -- point of call). procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); - -- Typ is a record or array type that is being frozen. This routine - -- sets the default component alignment from the scope stack values - -- if the alignment is otherwise not specified. + -- Typ is a record or array type that is being frozen. This routine sets + -- the default component alignment from the scope stack values if the + -- alignment is otherwise not specified. procedure Check_Debug_Info_Needed (T : Entity_Id); -- As each entity is frozen, this routine is called to deal with the @@ -162,9 +163,9 @@ package body Freeze is -- subsidiary entities have the flag set as required. procedure Undelay_Type (T : Entity_Id); - -- T is a type of a component that we know to be an Itype. - -- We don't want this to have a Freeze_Node, so ensure it doesn't. - -- Do the same for any Full_View or Corresponding_Record_Type. + -- T is a type of a component that we know to be an Itype. We don't want + -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any + -- Full_View or Corresponding_Record_Type. procedure Warn_Overlay (Expr : Node_Id; @@ -233,7 +234,7 @@ package body Freeze is (not In_Same_Source_Unit (Renamed_Subp, Ent) or else Sloc (Renamed_Subp) < Sloc (Ent)) - -- We can make the renaming entity intrisic if the renamed function + -- We can make the renaming entity intrinsic if the renamed function -- has an interface name, or if it is one of the shift/rotate -- operations known to the compiler. @@ -361,10 +362,13 @@ package body Freeze is -- For simple renamings, subsequent calls can be expanded directly as -- calls to the renamed entity. The body must be generated in any case - -- for calls that may appear elsewhere. + -- for calls that may appear elsewhere. This is not done in the case + -- where the subprogram is an instantiation because the actual proper + -- body has not been built yet. if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration + and then not Is_Generic_Instance (Old_S) then Set_Body_To_Inline (Decl, Old_S); end if; @@ -623,13 +627,6 @@ package body Freeze is if S > 32 then return; - -- Don't bother if alignment clause with a value other than 1 is - -- present, because size may be padded up to meet back end alignment - -- requirements, and only the back end knows the rules! - - elsif Known_Alignment (T) and then Alignment (T) /= 1 then - return; - -- Check for bad size clause given elsif Has_Size_Clause (T) then @@ -638,21 +635,12 @@ package body Freeze is Error_Msg_NE ("size for& too small, minimum allowed is ^", Size_Clause (T), T); - - elsif Unknown_Esize (T) then - Set_Esize (T, S); end if; - -- Set sizes if not set already + -- Set size if not set already - else - if Unknown_Esize (T) then - Set_Esize (T, S); - end if; - - if Unknown_RM_Size (T) then - Set_RM_Size (T, S); - end if; + elsif Unknown_RM_Size (T) then + Set_RM_Size (T, S); end if; end Set_Small_Size; @@ -783,7 +771,7 @@ package body Freeze is return False; -- A subtype of a variant record must not have non-static - -- discriminanted components. + -- discriminated components. elsif T /= Base_Type (T) and then not Static_Discriminated_Components (T) @@ -836,7 +824,7 @@ package body Freeze is if not Is_Constrained (T) and then No (Discriminant_Default_Value (First_Discriminant (T))) - and then Unknown_Esize (T) + and then Unknown_RM_Size (T) then return False; end if; @@ -1208,7 +1196,6 @@ package body Freeze is -- as they are generated. procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is - Loc : constant Source_Ptr := Sloc (After); E : Entity_Id; Decl : Node_Id; @@ -1276,6 +1263,13 @@ package body Freeze is End_Package_Scope (E); + if Is_Generic_Instance (E) + and then Has_Delayed_Freeze (E) + then + Set_Has_Delayed_Freeze (E, False); + Expand_N_Package_Declaration (Unit_Declaration_Node (E)); + end if; + elsif Ekind (E) in Task_Kind and then (Nkind (Parent (E)) = N_Task_Type_Declaration @@ -1304,14 +1298,14 @@ package body Freeze is Subp : Entity_Id; begin - Prim := First_Elmt (Prim_List); + Prim := First_Elmt (Prim_List); while Present (Prim) loop Subp := Node (Prim); if Comes_From_Source (Subp) and then not Is_Frozen (Subp) then - Flist := Freeze_Entity (Subp, Loc); + Flist := Freeze_Entity (Subp, After); Process_Flist; end if; @@ -1321,13 +1315,37 @@ package body Freeze is end if; if not Is_Frozen (E) then - Flist := Freeze_Entity (E, Loc); + Flist := Freeze_Entity (E, After); Process_Flist; + + -- If already frozen, and there are delayed aspects, this is where + -- we do the visibility check for these aspects (see Sem_Ch13 spec + -- for a description of how we handle aspect visibility). + + elsif Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + then + Check_Aspect_At_End_Of_Declarations (Ritem); + end if; + + Ritem := Next_Rep_Item (Ritem); + end loop; + end; end if; -- If an incomplete type is still not frozen, this may be a -- premature freezing because of a body declaration that follows. - -- Indicate where the freezing took place. + -- Indicate where the freezing took place. Freezing will happen + -- if the body comes from source, but not if it is internally + -- generated, for example as the body of a type invariant. -- If the freezing is caused by the end of the current declarative -- part, it is a Taft Amendment type, and there is no error. @@ -1339,14 +1357,23 @@ package body Freeze is Bod : constant Node_Id := Next (After); begin + -- The presence of a body freezes all entities previously + -- declared in the current list of declarations, but this + -- does not apply if the body does not come from source. + -- A type invariant is transformed into a subprogram body + -- which is placed at the end of the private part of the + -- current package, but this body does not freeze incomplete + -- types that may be declared in this private part. + if (Nkind_In (Bod, N_Subprogram_Body, N_Entry_Body, N_Package_Body, N_Protected_Body, N_Task_Body) or else Nkind (Bod) in N_Body_Stub) - and then - List_Containing (After) = List_Containing (Parent (E)) + and then + List_Containing (After) = List_Containing (Parent (E)) + and then Comes_From_Source (Bod) then Error_Msg_Sloc := Sloc (Next (After)); Error_Msg_NE @@ -1392,7 +1419,11 @@ package body Freeze is Decl := Unit_Declaration_Node (E); if Nkind (Decl) = N_Subprogram_Renaming_Declaration then - Build_And_Analyze_Renamed_Body (Decl, E, After); + if Error_Posted (Decl) then + Set_Has_Completion (E); + else + Build_And_Analyze_Renamed_Body (Decl, E, After); + end if; elsif Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) @@ -1427,13 +1458,24 @@ package body Freeze is end loop; end; + -- We add finalization masters to access types whose designated types + -- require finalization. This is normally done when freezing the + -- type, but this misses recursive type definitions where the later + -- members of the recursion introduce controlled components (such as + -- can happen when incomplete types are involved), as well cases + -- where a component type is private and the controlled full type + -- occurs after the access type is frozen. Cases that don't need a + -- finalization master are generic formal types (the actual type will + -- have it) and types with Java and CIL conventions, since those are + -- used for API bindings. (Are there any other cases that should be + -- excluded here???) + elsif Is_Access_Type (E) and then Comes_From_Source (E) - and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type + and then not Is_Generic_Type (E) and then Needs_Finalization (Designated_Type (E)) - and then No (Associated_Final_Chain (E)) then - Build_Final_List (Parent (E), E); + Build_Finalization_Master (E); end if; Next_Entity (E); @@ -1446,10 +1488,10 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id) is - L : constant List_Id := Freeze_Entity (Ent, Loc); + L : constant List_Id := Freeze_Entity (Ent, N); begin if Is_Non_Empty_List (L) then if Result = No_List then @@ -1465,7 +1507,7 @@ package body Freeze is ------------------- procedure Freeze_Before (N : Node_Id; T : Entity_Id) is - Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); + Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); begin if Is_Non_Empty_List (Freeze_Nodes) then Insert_Actions (N, Freeze_Nodes); @@ -1476,18 +1518,24 @@ package body Freeze is -- Freeze_Entity -- ------------------- - function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); Test_E : Entity_Id := E; Comp : Entity_Id; F_Node : Node_Id; - Result : List_Id; Indx : Node_Id; Formal : Entity_Id; Atype : Entity_Id; + Result : List_Id := No_List; + -- List of freezing actions, left at No_List if none + Has_Default_Initialization : Boolean := False; -- This flag gets set to true for a variable with default initialization + procedure Add_To_Result (N : Node_Id); + -- N is a freezing action to be appended to the Result + procedure Check_Current_Instance (Comp_Decl : Node_Id); -- Check that an Access or Unchecked_Access attribute with a prefix -- which is the current instance type can only be applied when the type @@ -1506,6 +1554,19 @@ package body Freeze is -- Freeze each component, handle some representation clauses, and freeze -- primitive operations if this is a tagged type. + ------------------- + -- Add_To_Result -- + ------------------- + + procedure Add_To_Result (N : Node_Id) is + begin + if No (Result) then + Result := New_List (N); + else + Append (N, Result); + end if; + end Add_To_Result; + ---------------------------- -- After_Last_Declaration -- ---------------------------- @@ -1532,14 +1593,93 @@ package body Freeze is procedure Check_Current_Instance (Comp_Decl : Node_Id) is - Rec_Type : constant Entity_Id := - Scope (Defining_Identifier (Comp_Decl)); - - Decl : constant Node_Id := Parent (Rec_Type); + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; + -- Determine whether Typ is compatible with the rules for aliased + -- views of types as defined in RM 3.10 in the various dialects. function Process (N : Node_Id) return Traverse_Result; -- Process routine to apply check to given node + ----------------------------- + -- Is_Aliased_View_Of_Type -- + ----------------------------- + + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is + Typ_Decl : constant Node_Id := Parent (Typ); + + begin + -- Common case + + if Nkind (Typ_Decl) = N_Full_Type_Declaration + and then Limited_Present (Type_Definition (Typ_Decl)) + then + return True; + + -- The following paragraphs describe what a legal aliased view of + -- a type is in the various dialects of Ada. + + -- Ada 95 + + -- The current instance of a limited type, and a formal parameter + -- or generic formal object of a tagged type. + + -- Ada 95 limited type + -- * Type with reserved word "limited" + -- * A protected or task type + -- * A composite type with limited component + + elsif Ada_Version <= Ada_95 then + return Is_Limited_Type (Typ); + + -- Ada 2005 + + -- The current instance of a limited tagged type, a protected + -- type, a task type, or a type that has the reserved word + -- "limited" in its full definition ... a formal parameter or + -- generic formal object of a tagged type. + + -- Ada 2005 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + + elsif Ada_Version = Ada_2005 then + return + (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) + or else + (Is_Derived_Type (Typ) + and then not Is_Interface (Etype (Typ)) + and then Is_Limited_Type (Etype (Typ))); + + -- Ada 2012 and beyond + + -- The current instance of an immutably limited type ... a formal + -- parameter or generic formal object of a tagged type. + + -- Ada 2012 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + -- * An incomplete view + + -- Ada 2012 immutably limited type + -- * Explicitly limited record type + -- * Record extension with "limited" present + -- * Non-formal limited private type that is either tagged + -- or has at least one access discriminant with a default + -- expression + -- * Task type, protected type or synchronized interface + -- * Type derived from immutably limited type + + else + return + Is_Immutably_Limited_Type (Typ) + or else Is_Incomplete_Type (Typ); + end if; + end Is_Aliased_View_Of_Type; + ------------- -- Process -- ------------- @@ -1568,24 +1708,15 @@ package body Freeze is procedure Traverse is new Traverse_Proc (Process); - -- Start of processing for Check_Current_Instance - - begin - -- In Ada95, the (imprecise) rule is that the current instance of a - -- limited type is aliased. In Ada2005, limitedness must be explicit: - -- either a tagged type, or a limited record. + -- Local variables - if Is_Limited_Type (Rec_Type) - and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type)) - then - return; + Rec_Type : constant Entity_Id := + Scope (Defining_Identifier (Comp_Decl)); - elsif Nkind (Decl) = N_Full_Type_Declaration - and then Limited_Present (Type_Definition (Decl)) - then - return; + -- Start of processing for Check_Current_Instance - else + begin + if not Is_Aliased_View_Of_Type (Rec_Type) then Traverse (Comp_Decl); end if; end Check_Current_Instance; @@ -1601,6 +1732,7 @@ package body Freeze is if Nkind (Decl) = N_Full_Type_Declaration then declare Tdef : constant Node_Id := Type_Definition (Decl); + begin if Nkind (Tdef) = N_Modular_Type_Definition then declare @@ -1747,12 +1879,7 @@ package body Freeze is then IR := Make_Itype_Reference (Sloc (Comp)); Set_Itype (IR, Desig); - - if No (Result) then - Result := New_List (IR); - else - Append (IR, Result); - end if; + Add_To_Result (IR); end if; elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type @@ -1765,40 +1892,6 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin - -- If this is a subtype of a controlled type, declared without a - -- constraint, the _controller may not appear in the component list - -- if the parent was not frozen at the point of subtype declaration. - -- Inherit the _controller component now. - - if Rec /= Base_Type (Rec) - and then Has_Controlled_Component (Rec) - then - if Nkind (Parent (Rec)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (Rec))) - then - Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); - - -- If this is an internal type without a declaration, as for - -- record component, the base type may not yet be frozen, and its - -- controller has not been created. Add an explicit freeze node - -- for the itype, so it will be frozen after the base type. This - -- freeze node is used to communicate with the expander, in order - -- to create the controller for the enclosing record, and it is - -- deleted afterwards (see exp_ch3). It must not be created when - -- expansion is off, because it might appear in the wrong context - -- for the back end. - - elsif Is_Itype (Rec) - and then Has_Delayed_Freeze (Base_Type (Rec)) - and then - Nkind (Associated_Node_For_Itype (Rec)) = - N_Component_Declaration - and then Expander_Active - then - Ensure_Freeze_Node (Rec); - end if; - end if; - -- Freeze components and embedded subtypes Comp := First_Entity (Rec); @@ -1829,7 +1922,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); -- Check for error of component clause given for variable -- sized type. We have to delay this test till this point, @@ -1837,12 +1930,18 @@ package body Freeze is -- if it is variable length. We omit this test in a generic -- context, it will be applied at instantiation time. + -- We also omit this test in CodePeer mode, since we do not + -- have sufficient info on size and representation clauses. + if Present (CC) then Placed_Component := True; if Inside_A_Generic then null; + elsif CodePeer_Mode then + null; + elsif not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) @@ -1988,13 +2087,13 @@ package body Freeze is then if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append - (Entity (Expression (Alloc)), Loc, Result); + (Entity (Expression (Alloc)), N, Result); elsif Nkind (Expression (Alloc)) = N_Subtype_Indication then Freeze_And_Append (Entity (Subtype_Mark (Expression (Alloc))), - Loc, Result); + N, Result); end if; elsif Is_Itype (Designated_Type (Etype (Comp))) then @@ -2002,7 +2101,7 @@ package body Freeze is else Freeze_And_Append - (Designated_Type (Etype (Comp)), Loc, Result); + (Designated_Type (Etype (Comp)), N, Result); end if; end if; end; @@ -2023,14 +2122,14 @@ package body Freeze is then Freeze_And_Append (Designated_Type - (Component_Type (Etype (Comp))), Loc, Result); + (Component_Type (Etype (Comp))), N, Result); end if; Prev := Comp; Next_Entity (Comp); end loop; - -- Deal with pragma Bit_Order setting non-standard bit order + -- Deal with Bit_Order aspect specifying a non-default bit order if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then if not Placed_Component then @@ -2061,9 +2160,7 @@ package body Freeze is -- Set OK_To_Reorder_Components depending on debug flags - if Rec = Base_Type (Rec) - and then Convention (Rec) = Convention_Ada - then + if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) or else (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) @@ -2110,8 +2207,7 @@ package body Freeze is if Ekind (Rec) = E_Record_Type then if Present (Corresponding_Remote_Type (Rec)) then - Freeze_And_Append - (Corresponding_Remote_Type (Rec), Loc, Result); + Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); end if; Comp := First_Component (Rec); @@ -2133,18 +2229,16 @@ package body Freeze is (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); - exit; end if; if Has_Unchecked_Union (Etype (Comp)) then Set_Has_Unchecked_Union (Rec); end if; - if Has_Per_Object_Constraint (Comp) then - - -- Scan component declaration for likely misuses of current - -- instance, either in a constraint or a default expression. + -- Scan component declaration for likely misuses of current + -- instance, either in a constraint or a default expression. + if Has_Per_Object_Constraint (Comp) then Check_Current_Instance (Parent (Comp)); end if; @@ -2239,19 +2333,20 @@ package body Freeze is -- less than the sum of the object sizes (no point in packing if -- this is not the case). - and then Esize (Rec) < Scalar_Component_Total_Esize + and then RM_Size (Rec) < Scalar_Component_Total_Esize -- And the total RM size cannot be greater than the specified size -- since otherwise packing will not get us where we have to be! - and then Esize (Rec) >= Scalar_Component_Total_RM_Size + and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size - -- Never do implicit packing in CodePeer mode since we don't do - -- any packing in this mode, since this generates over-complex - -- code that confuses CodePeer, and in general, CodePeer does not - -- care about the internal representation of objects. + -- Never do implicit packing in CodePeer or Alfa modes since + -- we don't do any packing in these modes, since this generates + -- over-complex code that confuses static analysis, and in + -- general, neither CodePeer not GNATprove care about the + -- internal representation of objects. - and then not CodePeer_Mode + and then not (CodePeer_Mode or Alfa_Mode) then -- If implicit packing enabled, do it @@ -2301,6 +2396,16 @@ package body Freeze is elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then return No_List; + -- AI05-0213: A formal incomplete type does not freeze the actual. In + -- the instance, the same applies to the subtype renaming the actual. + + elsif Is_Private_Type (E) + and then Is_Generic_Actual_Type (E) + and then No (Full_View (Base_Type (E))) + and then Ada_Version >= Ada_2012 + then + return No_List; + -- Do not freeze a global entity within an inner scope created during -- expansion. A call to subprogram E within some internal procedure -- (a stream attribute for example) might require freezing E, but the @@ -2372,9 +2477,43 @@ package body Freeze is end; end if; + -- Deal with delayed aspect specifications. The analysis of the aspect + -- is required to be delayed to the freeze point, so we evaluate the + -- pragma or attribute definition clause in the tree at this point. + + if Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + Aitem : Node_Id; + + begin + -- Look for aspect specification entries for this entity + + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + and then Scope (E) = Current_Scope + then + Aitem := Aspect_Rep_Item (Ritem); + + -- Skip if this is an aspect with no corresponding pragma + -- or attribute definition node (such as Default_Value). + + if Present (Aitem) then + Set_Parent (Aitem, Ritem); + Analyze (Aitem); + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + -- Here to freeze the entity - Result := No_List; Set_Is_Frozen (E); -- Case of entity being frozen is other than a type @@ -2408,8 +2547,7 @@ package body Freeze is and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate - and then - Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) + and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) then null; end if; @@ -2433,7 +2571,19 @@ package body Freeze is Formal := First_Formal (E); while Present (Formal) loop F_Type := Etype (Formal); - Freeze_And_Append (F_Type, Loc, Result); + + -- AI05-0151 : incomplete types can appear in a profile. + -- By the time the entity is frozen, the full view must + -- be available, unless it is a limited view. + + if Is_Incomplete_Type (F_Type) + and then Present (Full_View (F_Type)) + then + F_Type := Full_View (F_Type); + Set_Etype (Formal, F_Type); + end if; + + Freeze_And_Append (F_Type, N, Result); if Is_Private_Type (F_Type) and then Is_Private_Type (Base_Type (F_Type)) @@ -2589,7 +2739,7 @@ package body Freeze is if Is_Itype (Etype (Formal)) and then Ekind (F_Type) = E_Subprogram_Type then - Freeze_And_Append (F_Type, Loc, Result); + Freeze_And_Append (F_Type, N, Result); end if; end if; @@ -2603,7 +2753,18 @@ package body Freeze is -- Freeze return type R_Type := Etype (E); - Freeze_And_Append (R_Type, Loc, Result); + + -- AI05-0151: the return type may have been incomplete + -- at the point of declaration. + + if Ekind (R_Type) = E_Incomplete_Type + and then Present (Full_View (R_Type)) + then + R_Type := Full_View (R_Type); + Set_Etype (E, R_Type); + end if; + + Freeze_And_Append (R_Type, N, Result); -- Check suspicious return type for C function @@ -2677,7 +2838,7 @@ package body Freeze is end if; end if; - -- Give warning for suspicous return of a result of an + -- Give warning for suspicious return of a result of an -- unconstrained array type in a foreign convention -- function. @@ -2689,7 +2850,8 @@ package body Freeze is and then not Is_Constrained (R_Type) -- Exclude imported routines, the warning does not - -- belong on the import, but on the routine definition. + -- belong on the import, but rather on the routine + -- definition. and then not Is_Imported (E) @@ -2716,7 +2878,7 @@ package body Freeze is -- Must freeze its parent first if it is a derived subprogram if Present (Alias (E)) then - Freeze_And_Append (Alias (E), Loc, Result); + Freeze_And_Append (Alias (E), N, Result); end if; -- We don't freeze internal subprograms, because we don't normally @@ -2740,7 +2902,7 @@ package body Freeze is if Present (Etype (E)) and then Ekind (E) /= E_Generic_Function then - Freeze_And_Append (Etype (E), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); end if; -- Special processing for objects created by object declaration @@ -2752,7 +2914,7 @@ package body Freeze is -- Note: we inhibit this check for objects that do not come -- from source because there is at least one case (the - -- expansion of x'class'input where x is abstract) where we + -- expansion of x'Class'Input where x is abstract) where we -- legitimately generate an abstract object. if Is_Abstract_Type (Etype (E)) @@ -2801,7 +2963,7 @@ package body Freeze is ((Has_Non_Null_Base_Init_Proc (Etype (E)) and then not No_Initialization (Declaration_Node (E)) and then not Is_Value_Type (Etype (E)) - and then not Suppress_Init_Proc (Etype (E))) + and then not Initialization_Suppressed (Etype (E))) or else (Needs_Simple_Initialization (Etype (E)) and then not Is_Internal (E))) @@ -2934,7 +3096,7 @@ package body Freeze is else -- 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 + -- pragma Preelaborable_Initialization, 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 @@ -2947,8 +3109,13 @@ package body Freeze is -- nable and used in subsequent checks, so might as well try to -- compute it. + -- In Ada 2012, Freeze_Entities is also used in the front end to + -- trigger the analysis of aspect expressions, so in this case we + -- want to continue the freezing process. + if Present (Scope (E)) and then Is_Generic_Unit (Scope (E)) + and then not Has_Predicates (E) then Check_Compile_Time_Size (E); return No_List; @@ -2989,16 +3156,16 @@ package body Freeze is -- action that causes stuff to be inherited). if Present (Size_Clause (E)) - and then Known_Static_Esize (E) + and then Known_Static_RM_Size (E) and then not Is_Packed (E) and then not Has_Pragma_Pack (E) and then Number_Dimensions (E) = 1 and then not Has_Component_Size_Clause (E) - and then Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) and then not Is_Limited_Composite (E) and then not Is_Packed (Root_Type (E)) and then not Has_Component_Size_Clause (Root_Type (E)) - and then not CodePeer_Mode + and then not (CodePeer_Mode or Alfa_Mode) then Get_Index_Bounds (First_Index (E), Lo, Hi); @@ -3070,25 +3237,38 @@ package body Freeze is end if; -- If ancestor subtype present, freeze that first. Note that this - -- will also get the base type frozen. + -- will also get the base type frozen. Need RM reference ??? Atype := Ancestor_Subtype (E); if Present (Atype) then - Freeze_And_Append (Atype, Loc, Result); + Freeze_And_Append (Atype, N, Result); - -- Otherwise freeze the base type of the entity before freezing - -- the entity itself (RM 13.14(15)). + -- No ancestor subtype present - elsif E /= Base_Type (E) then - Freeze_And_Append (Base_Type (E), Loc, Result); + else + -- See if we have a nearest ancestor that has a predicate. + -- That catches the case of derived type with a predicate. + -- Need RM reference here ??? + + Atype := Nearest_Ancestor (E); + + if Present (Atype) and then Has_Predicates (Atype) then + Freeze_And_Append (Atype, N, Result); + end if; + + -- Freeze base type before freezing the entity (RM 13.14(15)) + + if E /= Base_Type (E) then + Freeze_And_Append (Base_Type (E), N, Result); + end if; end if; -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then - Freeze_And_Append (Etype (E), Loc, Result); - Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); + Freeze_And_Append (First_Subtype (Etype (E)), N, Result); end if; -- For array type, freeze index types and component type first @@ -3105,11 +3285,11 @@ package body Freeze is -- with a non-standard representation. begin - Freeze_And_Append (Ctyp, Loc, Result); + Freeze_And_Append (Ctyp, N, Result); Indx := First_Index (E); while Present (Indx) loop - Freeze_And_Append (Etype (Indx), Loc, Result); + Freeze_And_Append (Etype (Indx), N, Result); if Is_Enumeration_Type (Etype (Indx)) and then Has_Non_Standard_Rep (Etype (Indx)) @@ -3354,12 +3534,34 @@ package body Freeze is -- Start of processing for Alias_Atomic_Check begin - -- Case where component size has no effect - if Known_Static_Esize (Ctyp) - and then Known_Static_RM_Size (Ctyp) - and then Esize (Ctyp) = RM_Size (Ctyp) - and then Esize (Ctyp) mod 8 = 0 + -- If object size of component type isn't known, we + -- cannot be sure so we defer to the back end. + + if not Known_Static_Esize (Ctyp) then + null; + + -- Case where component size has no effect. First + -- check for object size of component type multiple + -- of the storage unit size. + + elsif Esize (Ctyp) mod System_Storage_Unit = 0 + + -- OK in both packing case and component size case + -- if RM size is known and static and the same as + -- the object size. + + and then + ((Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp)) + + -- Or if we have an explicit component size + -- clause and the component size and object size + -- are equal. + + or else + (Has_Component_Size_Clause (E) + and then Component_Size (E) = Esize (Ctyp))) then null; @@ -3438,9 +3640,9 @@ package body Freeze is end; end if; - -- If any of the index types was an enumeration type with - -- a non-standard rep clause, then we indicate that the - -- array type is always packed (even if it is not bit packed). + -- If any of the index types was an enumeration type with a + -- non-standard rep clause, then we indicate that the array + -- type is always packed (even if it is not bit packed). if Non_Standard_Enum then Set_Has_Non_Standard_Rep (Base_Type (E)); @@ -3458,7 +3660,7 @@ package body Freeze is and then Ekind (E) /= E_String_Literal_Subtype then Create_Packed_Array_Type (E); - Freeze_And_Append (Packed_Array_Type (E), Loc, Result); + Freeze_And_Append (Packed_Array_Type (E), N, Result); -- Size information of packed array type is copied to the -- array type, since this is really the representation. But @@ -3501,7 +3703,7 @@ package body Freeze is -- frozen as well (RM 13.14(15)) elsif Is_Class_Wide_Type (E) then - Freeze_And_Append (Root_Type (E), Loc, Result); + Freeze_And_Append (Root_Type (E), N, Result); -- If the base type of the class-wide type is still incomplete, -- the class-wide remains unfrozen as well. This is legal when @@ -3527,11 +3729,7 @@ package body Freeze is begin Set_Itype (Ref, E); - if No (Result) then - Result := New_List (Ref); - else - Append (Ref, Result); - end if; + Add_To_Result (Ref); end; end if; @@ -3541,7 +3739,7 @@ package body Freeze is if Ekind (E) = E_Class_Wide_Subtype and then Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; -- For a record (sub)type, freeze all the component types (RM @@ -3565,13 +3763,13 @@ package body Freeze is elsif Is_Concurrent_Type (E) then if Present (Corresponding_Record_Type (E)) then Freeze_And_Append - (Corresponding_Record_Type (E), Loc, Result); + (Corresponding_Record_Type (E), N, Result); end if; Comp := First_Entity (E); while Present (Comp) loop if Is_Type (Comp) then - Freeze_And_Append (Comp, Loc, Result); + Freeze_And_Append (Comp, N, Result); elsif (Ekind (Comp)) /= E_Function then if Is_Itype (Etype (Comp)) @@ -3580,7 +3778,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); end if; Next_Entity (Comp); @@ -3613,7 +3811,7 @@ package body Freeze is -- package Pkg is -- type T is tagged private; -- type DT is new T with private; - -- procedure Prim (X : in out T; Y : in out DT'class); + -- procedure Prim (X : in out T; Y : in out DT'Class); -- private -- type T is tagged null record; -- Obj : T; @@ -3638,7 +3836,6 @@ package body Freeze is -- processing is required if Is_Frozen (Full_View (E)) then - Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty); Check_Debug_Info_Needed (E); @@ -3655,10 +3852,10 @@ package body Freeze is and then Present (Underlying_Full_View (Full)) then Freeze_And_Append - (Underlying_Full_View (Full), Loc, Result); + (Underlying_Full_View (Full), N, Result); end if; - Freeze_And_Append (Full, Loc, Result); + Freeze_And_Append (Full, N, Result); if Has_Delayed_Freeze (E) then F_Node := Freeze_Node (Full); @@ -3746,7 +3943,7 @@ package body Freeze is end if; end if; - Freeze_And_Append (Etype (Formal), Loc, Result); + Freeze_And_Append (Etype (Formal), N, Result); Next_Formal (Formal); end loop; @@ -3758,7 +3955,7 @@ package body Freeze is elsif Is_Access_Protected_Subprogram_Type (E) then if Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; end if; @@ -3780,9 +3977,7 @@ package body Freeze is -- these till the freeze-point since we need the small and range -- values. We only do these checks for base types - if Is_Ordinary_Fixed_Point_Type (E) - and then E = Base_Type (E) - then + if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then if Small_Value (E) < Ureal_2_M_80 then Error_Msg_Name_1 := Name_Small; Error_Msg_N @@ -3821,6 +4016,28 @@ package body Freeze is elsif Is_Access_Type (E) then + -- If a pragma Default_Storage_Pool applies, and this type has no + -- Storage_Pool or Storage_Size clause (which must have occurred + -- before the freezing point), then use the default. This applies + -- only to base types. + + if Present (Default_Pool) + and then Is_Base_Type (E) + and then not Has_Storage_Size_Clause (E) + and then No (Associated_Storage_Pool (E)) + then + -- Case of pragma Default_Storage_Pool (null) + + if Nkind (Default_Pool) = N_Null then + Set_No_Pool_Assigned (E); + + -- Case of pragma Default_Storage_Pool (storage_pool_NAME) + + else + Set_Associated_Storage_Pool (E, Entity (Default_Pool)); + end if; + end if; + -- Check restriction for standard storage pool if No (Associated_Storage_Pool (E)) then @@ -3887,6 +4104,276 @@ package body Freeze is end loop; end; end if; + + -- If the type is a simple storage pool type, then this is where + -- we attempt to locate and validate its Allocate, Deallocate, and + -- Storage_Size operations (the first is required, and the latter + -- two are optional). We also verify that the full type for a + -- private type is allowed to be a simple storage pool type. + + if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type)) + and then (Is_Base_Type (E) or else Has_Private_Declaration (E)) + then + -- If the type is marked Has_Private_Declaration, then this is + -- a full type for a private type that was specified with the + -- pragma Simple_Storage_Pool_Type, and here we ensure that the + -- pragma is allowed for the full type (for example, it can't + -- be an array type, or a nonlimited record type). + + if Has_Private_Declaration (E) then + if (not Is_Record_Type (E) + or else not Is_Immutably_Limited_Type (E)) + and then not Is_Private_Type (E) + then + Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; + Error_Msg_N + ("pragma% can only apply to full type that is an " & + "explicitly limited type", E); + end if; + end if; + + Validate_Simple_Pool_Ops : declare + Pool_Type : Entity_Id renames E; + Address_Type : constant Entity_Id := RTE (RE_Address); + Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count); + + procedure Validate_Simple_Pool_Op_Formal + (Pool_Op : Entity_Id; + Pool_Op_Formal : in out Entity_Id; + Expected_Mode : Formal_Kind; + Expected_Type : Entity_Id; + Formal_Name : String; + OK_Formal : in out Boolean); + -- Validate one formal Pool_Op_Formal of the candidate pool + -- operation Pool_Op. The formal must be of Expected_Type + -- and have mode Expected_Mode. OK_Formal will be set to + -- False if the formal doesn't match. If OK_Formal is False + -- on entry, then the formal will effectively be ignored + -- (because validation of the pool op has already failed). + -- Upon return, Pool_Op_Formal will be updated to the next + -- formal, if any. + + procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id); + -- Search for and validate a simple pool operation with the + -- name Op_Name. If the name is Allocate, then there must be + -- exactly one such primitive operation for the simple pool + -- type. If the name is Deallocate or Storage_Size, then + -- there can be at most one such primitive operation. The + -- profile of the located primitive must conform to what + -- is expected for each operation. + + ------------------------------------ + -- Validate_Simple_Pool_Op_Formal -- + ------------------------------------ + + procedure Validate_Simple_Pool_Op_Formal + (Pool_Op : Entity_Id; + Pool_Op_Formal : in out Entity_Id; + Expected_Mode : Formal_Kind; + Expected_Type : Entity_Id; + Formal_Name : String; + OK_Formal : in out Boolean) + is + begin + -- If OK_Formal is False on entry, then simply ignore + -- the formal, because an earlier formal has already + -- been flagged. + + if not OK_Formal then + return; + + -- If no formal is passed in, then issue an error for a + -- missing formal. + + elsif not Present (Pool_Op_Formal) then + Error_Msg_NE + ("simple storage pool op missing formal " & + Formal_Name & " of type&", Pool_Op, Expected_Type); + OK_Formal := False; + + return; + end if; + + if Etype (Pool_Op_Formal) /= Expected_Type then + + -- If the pool type was expected for this formal, then + -- this will not be considered a candidate operation + -- for the simple pool, so we unset OK_Formal so that + -- the op and any later formals will be ignored. + + if Expected_Type = Pool_Type then + OK_Formal := False; + + return; + + else + Error_Msg_NE + ("wrong type for formal " & Formal_Name & + " of simple storage pool op; expected type&", + Pool_Op_Formal, Expected_Type); + end if; + end if; + + -- Issue error if formal's mode is not the expected one + + if Ekind (Pool_Op_Formal) /= Expected_Mode then + Error_Msg_N + ("wrong mode for formal of simple storage pool op", + Pool_Op_Formal); + end if; + + -- Advance to the next formal + + Next_Formal (Pool_Op_Formal); + end Validate_Simple_Pool_Op_Formal; + + ------------------------------------ + -- Validate_Simple_Pool_Operation -- + ------------------------------------ + + procedure Validate_Simple_Pool_Operation + (Op_Name : Name_Id) + is + Op : Entity_Id; + Found_Op : Entity_Id := Empty; + Formal : Entity_Id; + Is_OK : Boolean; + + begin + pragma Assert + (Op_Name = Name_Allocate + or else Op_Name = Name_Deallocate + or else Op_Name = Name_Storage_Size); + + Error_Msg_Name_1 := Op_Name; + + -- For each homonym declared immediately in the scope + -- of the simple storage pool type, determine whether + -- the homonym is an operation of the pool type, and, + -- if so, check that its profile is as expected for + -- a simple pool operation of that name. + + Op := Get_Name_Entity_Id (Op_Name); + while Present (Op) loop + if Ekind_In (Op, E_Function, E_Procedure) + and then Scope (Op) = Current_Scope + then + Formal := First_Entity (Op); + + Is_OK := True; + + -- The first parameter must be of the pool type + -- in order for the operation to qualify. + + if Op_Name = Name_Storage_Size then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, Pool_Type, + "Pool", Is_OK); + else + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Out_Parameter, Pool_Type, + "Pool", Is_OK); + end if; + + -- If another operation with this name has already + -- been located for the type, then flag an error, + -- since we only allow the type to have a single + -- such primitive. + + if Present (Found_Op) and then Is_OK then + Error_Msg_NE + ("only one % operation allowed for " & + "simple storage pool type&", Op, Pool_Type); + end if; + + -- In the case of Allocate and Deallocate, a formal + -- of type System.Address is required. + + if Op_Name = Name_Allocate then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_Out_Parameter, + Address_Type, "Storage_Address", Is_OK); + elsif Op_Name = Name_Deallocate then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Address_Type, "Storage_Address", Is_OK); + end if; + + -- In the case of Allocate and Deallocate, formals + -- of type Storage_Count are required as the third + -- and fourth parameters. + + if Op_Name /= Name_Storage_Size then + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK); + Validate_Simple_Pool_Op_Formal + (Op, Formal, E_In_Parameter, + Stg_Cnt_Type, "Alignment", Is_OK); + end if; + + -- If no mismatched formals have been found (Is_OK) + -- and no excess formals are present, then this + -- operation has been validated, so record it. + + if not Present (Formal) and then Is_OK then + Found_Op := Op; + end if; + end if; + + Op := Homonym (Op); + end loop; + + -- There must be a valid Allocate operation for the type, + -- so issue an error if none was found. + + if Op_Name = Name_Allocate + and then not Present (Found_Op) + then + Error_Msg_N ("missing % operation for simple " & + "storage pool type", Pool_Type); + + elsif Present (Found_Op) then + + -- Simple pool operations can't be abstract + + if Is_Abstract_Subprogram (Found_Op) then + Error_Msg_N + ("simple storage pool operation must not be " & + "abstract", Found_Op); + end if; + + -- The Storage_Size operation must be a function with + -- Storage_Count as its result type. + + if Op_Name = Name_Storage_Size then + if Ekind (Found_Op) = E_Procedure then + Error_Msg_N + ("% operation must be a function", Found_Op); + + elsif Etype (Found_Op) /= Stg_Cnt_Type then + Error_Msg_NE + ("wrong result type for%, expected type&", + Found_Op, Stg_Cnt_Type); + end if; + + -- Allocate and Deallocate must be procedures + + elsif Ekind (Found_Op) = E_Function then + Error_Msg_N + ("% operation must be a procedure", Found_Op); + end if; + end if; + end Validate_Simple_Pool_Operation; + + -- Start of processing for Validate_Simple_Pool_Ops + + begin + Validate_Simple_Pool_Operation (Name_Allocate); + Validate_Simple_Pool_Operation (Name_Deallocate); + Validate_Simple_Pool_Operation (Name_Storage_Size); + end Validate_Simple_Pool_Ops; + end if; end if; -- Now that all types from which E may depend are frozen, see if the @@ -3916,14 +4403,16 @@ package body Freeze is end if; end if; - -- Remaining process is to set/verify the representation information, - -- in particular the size and alignment values. This processing is - -- not required for generic types, since generic types do not play - -- any part in code generation, and so the size and alignment values - -- for such types are irrelevant. + -- Now we set/verify the representation information, in particular + -- the size and alignment values. This processing is not required for + -- generic types, since generic types do not play any part in code + -- generation, and so the size and alignment values for such types + -- are irrelevant. Ditto for types declared within a generic unit, + -- which may have components that depend on generic parameters, and + -- that will be recreated in an instance. - if Is_Generic_Type (E) then - return Result; + if Inside_A_Generic then + null; -- Otherwise we call the layout procedure @@ -3931,6 +4420,51 @@ package body Freeze is Layout_Type (E); end if; + -- If this is an access to subprogram whose designated type is itself + -- a subprogram type, the return type of this anonymous subprogram + -- type must be decorated as well. + + if Ekind (E) = E_Anonymous_Access_Subprogram_Type + and then Ekind (Designated_Type (E)) = E_Subprogram_Type + then + Layout_Type (Etype (Designated_Type (E))); + end if; + + -- If the type has a Defaut_Value/Default_Component_Value aspect, + -- this is where we analye the expression (after the type is frozen, + -- since in the case of Default_Value, we are analyzing with the + -- type itself, and we treat Default_Component_Value similarly for + -- the sake of uniformity. + + if Is_First_Subtype (E) and then Has_Default_Aspect (E) then + declare + Nam : Name_Id; + Exp : Node_Id; + Typ : Entity_Id; + + begin + if Is_Scalar_Type (E) then + Nam := Name_Default_Value; + Typ := E; + Exp := Default_Aspect_Value (Typ); + else + Nam := Name_Default_Component_Value; + Typ := Component_Type (E); + Exp := Default_Aspect_Component_Value (E); + end if; + + Analyze_And_Resolve (Exp, Typ); + + if Etype (Exp) /= Any_Type then + if not Is_Static_Expression (Exp) then + Error_Msg_Name_1 := Nam; + Flag_Non_Static_Expr + ("aspect% requires static expression", Exp); + end if; + end if; + end; + end if; + -- End of freeze processing for type entities end if; @@ -3958,12 +4492,7 @@ package body Freeze is end if; Set_Entity (F_Node, E); - - if Result = No_List then - Result := New_List (F_Node); - else - Append (F_Node, Result); - end if; + Add_To_Result (F_Node); -- A final pass over record types with discriminants. If the type -- has an incomplete declaration, there may be constrained access @@ -4008,7 +4537,7 @@ package body Freeze is -- since obviously the first subtype depends on its own base type. if Is_Type (E) then - Freeze_And_Append (First_Subtype (E), Loc, Result); + Freeze_And_Append (First_Subtype (E), N, Result); -- If we just froze a tagged non-class wide record, then freeze the -- corresponding class-wide type. This must be done after the tagged @@ -4019,7 +4548,7 @@ package body Freeze is and then not Is_Class_Wide_Type (E) and then Present (Class_Wide_Type (E)) then - Freeze_And_Append (Class_Wide_Type (E), Loc, Result); + Freeze_And_Append (Class_Wide_Type (E), N, Result); end if; end if; @@ -4041,6 +4570,8 @@ package body Freeze is -- subprogram in main unit, generate descriptor if we are in -- Propagate_Exceptions mode. + -- This is very odd code, it makes a null result, why ??? + elsif Propagate_Exceptions and then Is_Imported (E) and then not Is_Intrinsic_Subprogram (E) @@ -4064,7 +4595,8 @@ package body Freeze is -- By default, if no size clause is present, an enumeration type with -- Convention C is assumed to interface to a C enum, and has integer -- size. This applies to types. For subtypes, verify that its base - -- type has no size clause either. + -- type has no size clause either. Treat other foreign conventions + -- in the same way, and also make sure alignment is set right. if Has_Foreign_Convention (Typ) and then not Has_Size_Clause (Typ) @@ -4072,6 +4604,7 @@ package body Freeze is and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); + Set_Alignment (Typ, Alignment (Standard_Integer)); else -- If the enumeration type interfaces to C, and it has a size clause @@ -4172,13 +4705,23 @@ package body Freeze is -- If expression is non-static, then it does not freeze in a default -- expression, see section "Handling of Default Expressions" in the - -- spec of package Sem for further details. Note that we have to - -- make sure that we actually have a real expression (if we have - -- a subtype indication, we can't test Is_Static_Expression!) + -- spec of package Sem for further details. Note that we have to make + -- sure that we actually have a real expression (if we have a subtype + -- indication, we can't test Is_Static_Expression!) However, we exclude + -- the case of the prefix of an attribute of a static scalar subtype + -- from this early return, because static subtype attributes should + -- always cause freezing, even in default expressions, but the attribute + -- may not have been marked as static yet (because in Resolve_Attribute, + -- the call to Eval_Attribute follows the call of Freeze_Expression on + -- the prefix). if In_Spec_Exp and then Nkind (N) in N_Subexpr and then not Is_Static_Expression (N) + and then (Nkind (Parent (N)) /= N_Attribute_Reference + or else not (Is_Entity_Name (N) + and then Is_Type (Entity (N)) + and then Is_Static_Subtype (Entity (N)))) then return; end if; @@ -4441,33 +4984,34 @@ package body Freeze is -- is a statement or declaration and we can insert the freeze node -- before it. - when N_Package_Specification | + when N_Block_Statement | + N_Entry_Body | N_Package_Body | - N_Subprogram_Body | - N_Task_Body | + N_Package_Specification | N_Protected_Body | - N_Entry_Body | - N_Block_Statement => exit; + N_Subprogram_Body | + N_Task_Body => exit; -- The expander is allowed to define types in any statements list, -- so any of the following parent nodes also mark a freezing point -- if the actual node is in a list of statements or declarations. - when N_Exception_Handler | - N_If_Statement | - N_Elsif_Part | + when N_Abortable_Part | + N_Accept_Alternative | + N_And_Then | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | - N_Selective_Accept | - N_Accept_Alternative | - N_Delay_Alternative | N_Conditional_Entry_Call | + N_Delay_Alternative | + N_Elsif_Part | N_Entry_Call_Alternative | - N_Triggering_Alternative | - N_Abortable_Part | - N_And_Then | + N_Exception_Handler | + N_Extended_Return_Statement | + N_Freeze_Entity | + N_If_Statement | N_Or_Else | - N_Freeze_Entity => + N_Selective_Accept | + N_Triggering_Alternative => exit when Is_List_Member (P); @@ -4525,35 +5069,39 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - Loc : constant Source_Ptr := Sloc (Current_Scope); - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + N : constant Node_Id := Current_Scope; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; begin if Present (Desig_Typ) then - Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); end if; if Present (Typ) then - Freeze_And_Append (Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Typ, N, Freeze_Nodes); end if; if Present (Nam) then - Freeze_And_Append (Nam, Loc, Freeze_Nodes); + Freeze_And_Append (Nam, N, Freeze_Nodes); end if; -- The current scope may be that of a constrained component of -- an enclosing record declaration, which is above the current -- scope in the scope stack. + -- If the expression is within a top-level pragma, as for a pre- + -- condition on a library-level subprogram, nothing to do. - if Is_Record_Type (Scope (Current_Scope)) then + if not Is_Compilation_Unit (Current_Scope) + and then Is_Record_Type (Scope (Current_Scope)) + then Pos := Pos - 1; end if; if Is_Non_Empty_List (Freeze_Nodes) then if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then Scope_Stack.Table (Pos).Pending_Freeze_Actions := - Freeze_Nodes; + Freeze_Nodes; else Append_List (Freeze_Nodes, Scope_Stack.Table (Pos).Pending_Freeze_Actions); @@ -5056,7 +5604,7 @@ package body Freeze is begin Set_Has_Delayed_Freeze (T); - L := Freeze_Entity (T, Sloc (N)); + L := Freeze_Entity (T, N); if Is_Non_Empty_List (L) then Insert_Actions (N, L); @@ -5328,13 +5876,13 @@ package body Freeze is and then Mechanism (E) not in Descriptor_Codes - -- Check appropriate warning is enabled (should we check for - -- Warnings (Off) on specific entities here, probably so???) + -- Check appropriate warning is enabled (should we check for + -- Warnings (Off) on specific entities here, probably so???) and then Warn_On_Export_Import - -- Exclude the VM case, since return of unconstrained arrays - -- is properly handled in both the JVM and .NET cases. + -- Exclude the VM case, since return of unconstrained arrays + -- is properly handled in both the JVM and .NET cases. and then VM_Target = No_VM then @@ -5598,16 +6146,14 @@ package body Freeze is Declarations => New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => New_Copy_Tree (Dcopy))), + Defining_Identifier => Make_Temporary (Loc, 'T'), + Object_Definition => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => New_Copy_Tree (Dcopy))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List)); + Statements => Empty_List)); Set_Scope (Dnam, Scope (E)); Set_Assignment_OK (First (Declarations (Dbody))); @@ -5728,15 +6274,16 @@ package body Freeze is -- tested for because predefined String types are initialized by inline -- code rather than by an init_proc). Note that we do not give the -- warning for Initialize_Scalars, since we suppressed initialization - -- in this case. + -- in this case. Also, do not warn if Suppress_Initialization is set. if Present (Expr) and then not Is_Imported (Ent) + and then not Initialization_Suppressed (Typ) and then (Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Access_Type (Typ) - or else (Normalize_Scalars - and then (Is_Scalar_Type (Typ) - or else Is_String_Type (Typ)))) + or else Is_Access_Type (Typ) + or else (Normalize_Scalars + and then (Is_Scalar_Type (Typ) + or else Is_String_Type (Typ)))) then if Nkind (Expr) = N_Attribute_Reference and then Is_Entity_Name (Prefix (Expr))