X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Ffreeze.adb;h=15bd6e075e3adfe2bc9e6735612a57831160ad55;hb=c0a208a52ba10b65d217c635ddddf7a07ea51ebd;hp=e9c715ef2b14fa813d6b0a62743ea836f578c460;hpb=701d57a469be1d9ec623d0896a939936df2a0593;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e9c715ef2b1..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; @@ -234,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. @@ -362,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; @@ -624,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 @@ -639,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 - - else - if Unknown_Esize (T) then - Set_Esize (T, S); - end if; + -- Set size if not set already - 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; @@ -784,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) @@ -837,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; @@ -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,7 +1298,7 @@ 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); @@ -1323,11 +1317,35 @@ package body Freeze is if not Is_Frozen (E) then 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); @@ -1481,14 +1523,19 @@ package body Freeze is 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 @@ -1507,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 -- ---------------------------- @@ -1533,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 -- ------------- @@ -1569,24 +1708,15 @@ package body Freeze is procedure Traverse is new Traverse_Proc (Process); - -- Start of processing for Check_Current_Instance + -- Local variables - 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. - - 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; @@ -1602,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 @@ -1748,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 @@ -1766,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); @@ -1838,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))) @@ -2031,7 +2129,7 @@ package body Freeze is 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 @@ -2062,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) @@ -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,10 +2477,8 @@ package body Freeze is end; end if; - -- Deal with delayed aspect specifications. At the point of occurrence - -- of the aspect definition, we preanalyzed the argument, to capture - -- the visibility at that point, but the actual analysis of the aspect - -- is required to be delayed to the freeze point, so we evalute the + -- 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 @@ -2384,13 +2487,24 @@ package body Freeze is 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 then + 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); - pragma Assert (Is_Delayed_Aspect (Aitem)); - Set_Parent (Aitem, Ritem); - Analyze (Aitem); + + -- 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); @@ -2400,7 +2514,6 @@ package body Freeze is -- Here to freeze the entity - Result := No_List; Set_Is_Frozen (E); -- Case of entity being frozen is other than a type @@ -2434,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; @@ -2459,6 +2571,18 @@ package body Freeze is Formal := First_Formal (E); while Present (Formal) loop F_Type := Etype (Formal); + + -- 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) @@ -2629,6 +2753,17 @@ package body Freeze is -- Freeze return type R_Type := Etype (E); + + -- 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 @@ -2703,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. @@ -2715,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) @@ -2778,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)) @@ -2827,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))) @@ -2960,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 @@ -2973,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; @@ -3015,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); @@ -3393,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; @@ -3566,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; @@ -3652,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; @@ -3818,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 @@ -3865,7 +4022,7 @@ package body Freeze is -- only to base types. if Present (Default_Pool) - and then E = Base_Type (E) + and then Is_Base_Type (E) and then not Has_Storage_Size_Clause (E) and then No (Associated_Storage_Pool (E)) then @@ -3947,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 @@ -3976,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 @@ -3991,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; @@ -4018,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 @@ -4101,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) @@ -4124,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) @@ -4132,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 @@ -4232,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; @@ -4501,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); @@ -5392,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 @@ -5662,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))); @@ -5792,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))