diff options
Diffstat (limited to 'gcc/ada/freeze.adb')
| -rw-r--r-- | gcc/ada/freeze.adb | 953 |
1 files changed, 766 insertions, 187 deletions
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 579c5ff5090..18f77f04283 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003, 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- -- @@ -33,6 +33,7 @@ with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; +with Exp_Tss; use Exp_Tss; with Layout; use Layout; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; @@ -78,6 +79,10 @@ package body Freeze is After : in out Node_Id); -- Build body for a renaming declaration, insert in tree and analyze. + procedure Check_Address_Clause (E : Entity_Id); + -- Apply legality checks to address clauses for object declarations, + -- at the point the object is frozen. + procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased -- or tagged or contains something this is aliased or tagged, set @@ -153,6 +158,16 @@ package body Freeze is -- needed -- see body for details). Never has any effect on T if the -- Debug_Info_Off flag is set. + procedure Warn_Overlay + (Expr : Node_Id; + Typ : Entity_Id; + Nam : Node_Id); + -- Expr is the expression for an address clause for entity Nam whose type + -- is Typ. If Typ has a default initialization, and there is no explicit + -- initialization in the source declaration, check whether the address + -- clause might cause overlaying of an entity, and emit a warning on the + -- side effect that the initialization will cause. + ------------------------------- -- Adjust_Esize_For_Alignment -- ------------------------------- @@ -196,8 +211,7 @@ package body Freeze is function Build_Renamed_Body (Decl : Node_Id; - New_S : Entity_Id) - return Node_Id + New_S : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (New_S); -- We use for the source location of the renamed body, the location @@ -232,7 +246,6 @@ package body Freeze is Old_S := Etype (Nam); elsif Nkind (Nam) = N_Indexed_Component then - if Is_Entity_Name (Prefix (Nam)) then Old_S := Entity (Prefix (Nam)); else @@ -412,6 +425,75 @@ package body Freeze is return Body_Node; end Build_Renamed_Body; + -------------------------- + -- Check_Address_Clause -- + -------------------------- + + procedure Check_Address_Clause (E : Entity_Id) is + Addr : constant Node_Id := Address_Clause (E); + Expr : Node_Id; + Decl : constant Node_Id := Declaration_Node (E); + Typ : constant Entity_Id := Etype (E); + + begin + if Present (Addr) then + Expr := Expression (Addr); + + -- If we have no initialization of any kind, then we don't + -- need to place any restrictions on the address clause, because + -- the object will be elaborated after the address clause is + -- evaluated. This happens if the declaration has no initial + -- expression, or the type has no implicit initialization, or + -- the object is imported. + + -- The same holds for all initialized scalar types and all + -- access types. Packed bit arrays of size up to 64 are + -- represented using a modular type with an initialization + -- (to zero) and can be processed like other initialized + -- scalar types. + + -- If the type is controlled, code to attach the object to a + -- finalization chain is generated at the point of declaration, + -- and therefore the elaboration of the object cannot be delayed: + -- the address expression must be a constant. + + if (No (Expression (Decl)) + and then not Controlled_Type (Typ) + and then + (not Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Imported (E))) + + or else + (Present (Expression (Decl)) + and then Is_Scalar_Type (Typ)) + + or else + Is_Access_Type (Typ) + + or else + (Is_Bit_Packed_Array (Typ) + and then + Is_Modular_Integer_Type (Packed_Array_Type (Typ))) + then + null; + + -- Otherwise, we require the address clause to be constant + -- because the call to the initialization procedure (or the + -- attach code) has to happen at the point of the declaration. + + else + Check_Constant_Address_Clause (Expr, E); + Set_Has_Delayed_Freeze (E, False); + end if; + + if not Error_Posted (Expr) + and then not Controlled_Type (Typ) + then + Warn_Overlay (Expr, Typ, Name (Addr)); + end if; + end if; + end Check_Address_Clause; + ----------------------------- -- Check_Compile_Time_Size -- ----------------------------- @@ -429,7 +511,7 @@ package body Freeze is function Static_Discriminated_Components (T : Entity_Id) return Boolean; -- If T is a constrained subtype, its size is not known if any of its -- discriminant constraints is not static and it is not a null record. - -- The test is conservative and doesn't check that the components are + -- The test is conservative and doesn't check that the components are -- in fact constrained by non-static discriminant values. Could be made -- more precise ??? @@ -487,7 +569,6 @@ package body Freeze is return not Is_Generic_Type (T); elsif Is_Array_Type (T) then - if Ekind (T) = E_String_Literal_Subtype then Set_Small_Size (Component_Size (T) * String_Literal_Length (T)); return True; @@ -567,74 +648,179 @@ package body Freeze is end if; elsif Is_Record_Type (T) then + + -- A class-wide type is never considered to have a known size + if Is_Class_Wide_Type (T) then return False; - elsif T /= Base_Type (T) then - return Size_Known_At_Compile_Time (Base_Type (T)) - and then Static_Discriminated_Components (T); + -- A subtype of a variant record must not have non-static + -- discriminanted components. + + elsif T /= Base_Type (T) + and then not Static_Discriminated_Components (T) + then + return False; -- Don't do any recursion on type with error posted, since -- we may have a malformed type that leads us into a loop elsif Error_Posted (T) then return False; + end if; - else - declare - Packed_Size_Known : Boolean := Is_Packed (T); - Packed_Size : Uint := Uint_0; + -- Now look at the components of the record - begin - -- Test for variant part present - - if Has_Discriminants (T) - and then Present (Parent (T)) - and then Nkind (Parent (T)) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Parent (T))) = - N_Record_Definition - and then not Null_Present (Type_Definition (Parent (T))) - and then Present (Variant_Part - (Component_List (Type_Definition (Parent (T))))) + declare + -- The following two variables are used to keep track of + -- the size of packed records if we can tell the size of + -- the packed record in the front end. Packed_Size_Known + -- is True if so far we can figure out the size. It is + -- initialized to True for a packed record, unless the + -- record has discriminants. The reason we eliminate the + -- discriminated case is that we don't know the way the + -- back end lays out discriminated packed records. If + -- Packed_Size_Known is True, then Packed_Size is the + -- size in bits so far. + + Packed_Size_Known : Boolean := + Is_Packed (T) + and then not Has_Discriminants (T); + + Packed_Size : Uint := Uint_0; + + begin + -- Test for variant part present + + if Has_Discriminants (T) + and then Present (Parent (T)) + and then Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = + N_Record_Definition + and then not Null_Present (Type_Definition (Parent (T))) + and then Present (Variant_Part + (Component_List (Type_Definition (Parent (T))))) + then + -- If variant part is present, and type is unconstrained, + -- then we must have defaulted discriminants, or a size + -- clause must be present for the type, or else the size + -- is definitely not known at compile time. + + if not Is_Constrained (T) + and then + No (Discriminant_Default_Value + (First_Discriminant (T))) + and then Unknown_Esize (T) then - -- If variant part is present, and type is unconstrained, - -- then we must have defaulted discriminants, or a size - -- clause must be present for the type, or else the size - -- is definitely not known at compile time. - - if not Is_Constrained (T) - and then - No (Discriminant_Default_Value - (First_Discriminant (T))) - and then Unknown_Esize (T) - then - return False; - else - -- We do not know the packed size, it is too much - -- trouble to figure it out. + return False; + end if; + end if; + -- Loop through components + + Comp := First_Entity (T); + while Present (Comp) loop + if Ekind (Comp) = E_Component + or else + Ekind (Comp) = E_Discriminant + then + Ctyp := Etype (Comp); + + -- We do not know the packed size if there is a + -- component clause present (we possibly could, + -- but this would only help in the case of a record + -- with partial rep clauses. That's because in the + -- case of full rep clauses, the size gets figured + -- out anyway by a different circuit). + + if Present (Component_Clause (Comp)) then Packed_Size_Known := False; end if; - end if; - Comp := First_Entity (T); - - while Present (Comp) loop - if Ekind (Comp) = E_Component - or else - Ekind (Comp) = E_Discriminant + -- We need to identify a component that is an array + -- where the index type is an enumeration type with + -- non-standard representation, and some bound of the + -- type depends on a discriminant. + + -- This is because gigi computes the size by doing a + -- substituation of the appropriate discriminant value + -- in the size expression for the base type, and gigi + -- is not clever enough to evaluate the resulting + -- expression (which involves a call to rep_to_pos) + -- at compile time. + + -- It would be nice if gigi would either recognize that + -- this expression can be computed at compile time, or + -- alternatively figured out the size from the subtype + -- directly, where all the information is at hand ??? + + if Is_Array_Type (Etype (Comp)) + and then Present (Packed_Array_Type (Etype (Comp))) then - Ctyp := Etype (Comp); + declare + Ocomp : constant Entity_Id := + Original_Record_Component (Comp); + OCtyp : constant Entity_Id := Etype (Ocomp); + Ind : Node_Id; + Indtyp : Entity_Id; + Lo, Hi : Node_Id; - if Present (Component_Clause (Comp)) then - Packed_Size_Known := False; - end if; + begin + Ind := First_Index (OCtyp); + while Present (Ind) loop + Indtyp := Etype (Ind); + + if Is_Enumeration_Type (Indtyp) + and then Has_Non_Standard_Rep (Indtyp) + then + Lo := Type_Low_Bound (Indtyp); + Hi := Type_High_Bound (Indtyp); + + if Is_Entity_Name (Lo) + and then + Ekind (Entity (Lo)) = E_Discriminant + then + return False; + + elsif Is_Entity_Name (Hi) + and then + Ekind (Entity (Hi)) = E_Discriminant + then + return False; + end if; + end if; + + Next_Index (Ind); + end loop; + end; + end if; - if not Size_Known (Ctyp) then - return False; + -- Clearly size of record is not known if the size of + -- one of the components is not known. - elsif Packed_Size_Known then + if not Size_Known (Ctyp) then + return False; + end if; + + -- Accumulate packed size if possible + + if Packed_Size_Known then + + -- We can only deal with elementary types, since for + -- non-elementary components, alignment enters into + -- the picture, and we don't know enough to handle + -- proper alignment in this context. Packed arrays + -- count as elementary if the representation is a + -- modular type. + if Is_Elementary_Type (Ctyp) + or else (Is_Array_Type (Ctyp) + and then + Present (Packed_Array_Type (Ctyp)) + and then + Is_Modular_Integer_Type + (Packed_Array_Type (Ctyp))) + then -- If RM_Size is known and static, then we can -- keep accumulating the packed size. @@ -645,10 +831,13 @@ package body Freeze is if RM_Size (Ctyp) = Uint_0 then Packed_Size_Known := False; - end if; - Packed_Size := - Packed_Size + RM_Size (Ctyp); + -- Normal case where we can keep accumulating + -- the packed array size. + + else + Packed_Size := Packed_Size + RM_Size (Ctyp); + end if; -- If we have a field whose RM_Size is not known -- then we can't figure out the packed size here. @@ -656,19 +845,25 @@ package body Freeze is else Packed_Size_Known := False; end if; + + -- If we have a non-elementary type we can't figure + -- out the packed array size (alignment issues). + + else + Packed_Size_Known := False; end if; end if; + end if; - Next_Entity (Comp); - end loop; + Next_Entity (Comp); + end loop; - if Packed_Size_Known then - Set_Small_Size (Packed_Size); - end if; + if Packed_Size_Known then + Set_Small_Size (Packed_Size); + end if; - return True; - end; - end if; + return True; + end; else return False; @@ -691,7 +886,6 @@ package body Freeze is and then Present (First_Component (T)) then Constraint := First_Elmt (Discriminant_Constraint (T)); - while Present (Constraint) loop if not Compile_Time_Known_Value (Node (Constraint)) then return False; @@ -752,7 +946,7 @@ package body Freeze is while Present (Comp) loop if not Is_Type (Comp) and then (Strict_Alignment (Etype (Comp)) - or else Is_Aliased (Comp)) + or else Is_Aliased (Comp)) then Set_Strict_Alignment (E); return; @@ -838,12 +1032,51 @@ package body Freeze is end if; return; - end if; end if; end loop; end Check_Unsigned_Type; + ----------------------------- + -- Expand_Atomic_Aggregate -- + ----------------------------- + + procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (E); + New_N : Node_Id; + Temp : Entity_Id; + + begin + if (Nkind (Parent (E)) = N_Object_Declaration + or else Nkind (Parent (E)) = N_Assignment_Statement) + and then Comes_From_Source (Parent (E)) + and then Nkind (E) = N_Aggregate + then + Temp := + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + New_N := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (E)); + Insert_Before (Parent (E), New_N); + Analyze (New_N); + + Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc)); + + -- To prevent the temporary from being constant-folded (which + -- would lead to the same piecemeal assignment on the original + -- target) indicate to the back-end that the temporary is a + -- variable with real storage. See description of this flag + -- in Einfo, and the notes on N_Assignment_Statement and + -- N_Object_Declaration in Sinfo. + + Set_Is_True_Constant (Temp, False); + end if; + end Expand_Atomic_Aggregate; + ---------------- -- Freeze_All -- ---------------- @@ -866,6 +1099,10 @@ package body Freeze is -- should not be recursive, we don't want to analyze those till -- we are sure that ALL the types are frozen). + -------------------- + -- Freeze_All_Ent -- + -------------------- + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) @@ -878,6 +1115,10 @@ package body Freeze is -- If freeze nodes are present, insert and analyze, and reset -- cursor for next insertion. + ------------------- + -- Process_Flist -- + ------------------- + procedure Process_Flist is begin if Is_Non_Empty_List (Flist) then @@ -892,6 +1133,8 @@ package body Freeze is end if; end Process_Flist; + -- Start or processing for Freeze_All_Ent + begin E := From; while Present (E) loop @@ -920,7 +1163,7 @@ package body Freeze is elsif Ekind (E) in Task_Kind and then (Nkind (Parent (E)) = N_Task_Type_Declaration - or else + or else Nkind (Parent (E)) = N_Single_Task_Declaration) then New_Scope (E); @@ -940,8 +1183,9 @@ package body Freeze is declare Prim_List : constant Elist_Id := Primitive_Operations (Etype (E)); - Prim : Elmt_Id; - Subp : Entity_Id; + + Prim : Elmt_Id; + Subp : Entity_Id; begin Prim := First_Elmt (Prim_List); @@ -966,6 +1210,38 @@ package body Freeze is Process_Flist; 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. + + -- If the freezing is caused by the end of the current + -- declarative part, it is a Taft Amendment type, and there + -- is no error. + + if not Is_Frozen (E) + and then Ekind (E) = E_Incomplete_Type + then + declare + Bod : constant Node_Id := Next (After); + + begin + if (Nkind (Bod) = N_Subprogram_Body + or else Nkind (Bod) = N_Entry_Body + or else Nkind (Bod) = N_Package_Body + or else Nkind (Bod) = N_Protected_Body + or else Nkind (Bod) = N_Task_Body + or else Nkind (Bod) in N_Body_Stub) + and then + List_Containing (After) = List_Containing (Parent (E)) + then + Error_Msg_Sloc := Sloc (Next (After)); + Error_Msg_NE + ("type& is frozen# before its full declaration", + Parent (E), E); + end if; + end; + end if; + Next_Entity (E); end loop; end Freeze_All_Ent; @@ -979,6 +1255,7 @@ package body Freeze is -- that require us to build a default expression functions. This is the -- point at which such functions are constructed (after all types that -- might be used in such expressions have been frozen). + -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members @@ -988,7 +1265,6 @@ package body Freeze is E := From; while Present (E) loop - if Is_Subprogram (E) then if not Default_Expressions_Processed (E) then @@ -1005,7 +1281,7 @@ package body Freeze is and then Present (Corresponding_Body (Decl)) and then Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) - = N_Subprogram_Renaming_Declaration + = N_Subprogram_Renaming_Declaration then Build_And_Analyze_Renamed_Body (Decl, Corresponding_Body (Decl), After); @@ -1015,12 +1291,11 @@ package body Freeze is elsif Ekind (E) in Task_Kind and then (Nkind (Parent (E)) = N_Task_Type_Declaration - or else + or else Nkind (Parent (E)) = N_Single_Task_Declaration) then declare Ent : Entity_Id; - begin Ent := First_Entity (E); @@ -1047,7 +1322,6 @@ package body Freeze is Next_Entity (E); end loop; - end Freeze_All; ----------------------- @@ -1077,15 +1351,10 @@ package body Freeze is procedure Freeze_Before (N : Node_Id; T : Entity_Id) is Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); - F : Node_Id; begin if Is_Non_Empty_List (Freeze_Nodes) then - F := First (Freeze_Nodes); - - if Present (F) then - Insert_Actions (N, Freeze_Nodes); - end if; + Insert_Actions (N, Freeze_Nodes); end if; end Freeze_Before; @@ -1119,7 +1388,7 @@ package body Freeze is ---------------------------- function After_Last_Declaration return Boolean is - Spec : Node_Id := Parent (Current_Scope); + Spec : constant Node_Id := Parent (Current_Scope); begin if Nkind (Spec) = N_Package_Specification then @@ -1146,6 +1415,10 @@ package body Freeze is function Process (N : Node_Id) return Traverse_Result; -- Process routine to apply check to given node. + ------------- + -- Process -- + ------------- + function Process (N : Node_Id) return Traverse_Result is begin case Nkind (N) is @@ -1182,6 +1455,7 @@ package body Freeze is procedure Freeze_Record_Type (Rec : Entity_Id) is Comp : Entity_Id; + IR : Node_Id; Junk : Boolean; ADC : Node_Id; @@ -1194,12 +1468,39 @@ package body Freeze is -- clause (used to warn about useless Bit_Order pragmas). 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 + -- a 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. + + elsif Is_Itype (Rec) + and then Has_Delayed_Freeze (Base_Type (Rec)) + and then + Nkind (Associated_Node_For_Itype (Rec)) = + N_Component_Declaration + then + Ensure_Freeze_Node (Rec); + end if; + end if; + -- Freeze components and embedded subtypes Comp := First_Entity (Rec); - while Present (Comp) loop - if not Is_Type (Comp) then Freeze_And_Append (Etype (Comp), Loc, Result); end if; @@ -1230,7 +1531,6 @@ package body Freeze is -- case freeze the subtype mark. if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then - if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append (Entity (Expression (Alloc)), Loc, Result); @@ -1241,6 +1541,7 @@ package body Freeze is (Entity (Subtype_Mark (Expression (Alloc))), Loc, Result); end if; + else Freeze_And_Append (Designated_Type (Etype (Comp)), Loc, Result); @@ -1258,6 +1559,24 @@ package body Freeze is then Set_Is_Frozen (Designated_Type (Etype (Comp))); + -- In addition, add an Itype_Reference to ensure that the + -- access subtype is elaborated early enough. This cannot + -- be done if the subtype may depend on discriminants. + + if Ekind (Comp) = E_Component + and then Is_Itype (Etype (Comp)) + and then not Has_Discriminants (Rec) + then + IR := Make_Itype_Reference (Sloc (Comp)); + Set_Itype (IR, Designated_Type (Etype (Comp))); + + if No (Result) then + Result := New_List (IR); + else + Append (IR, Result); + end if; + end if; + elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) and then Present (Parent (Comp)) @@ -1441,22 +1760,20 @@ package body Freeze is -- If this is the record corresponding to a remote type, -- freeze the remote type here since that is what we are - -- semantically freeing. This prevents having the freeze node - -- for that type in an inner scope. + -- semantically freezing. This prevents having the freeze + -- node for that type in an inner scope. -- Also, Check for controlled components and unchecked unions. -- Finally, enforce the restriction that access attributes with -- a current instance prefix can only apply to limited types. if Ekind (Rec) = E_Record_Type then - if Present (Corresponding_Remote_Type (Rec)) then Freeze_And_Append (Corresponding_Remote_Type (Rec), Loc, Result); end if; Comp := First_Component (Rec); - while Present (Comp) loop if Has_Controlled_Component (Etype (Comp)) or else (Chars (Comp) /= Name_uParent @@ -1518,7 +1835,7 @@ package body Freeze is -- Start of processing for Freeze_Entity begin - -- Do not freeze if already frozen since we only need one freeze node. + -- Do not freeze if already frozen since we only need one freeze node if Is_Frozen (E) then return No_List; @@ -1588,18 +1905,50 @@ package body Freeze is then Set_Encoded_Interface_Name (E, Get_Default_External_Name (E)); + + -- Special processing for atomic objects appearing in object decls + + elsif Is_Atomic (E) + and then Nkind (Parent (E)) = N_Object_Declaration + and then Present (Expression (Parent (E))) + then + declare + Expr : constant Node_Id := Expression (Parent (E)); + + begin + -- If expression is an aggregate, assign to a temporary to + -- ensure that the actual assignment is done atomically rather + -- than component-wise (the assignment to the temp may be done + -- component-wise, but that is harmless. + + if Nkind (Expr) = N_Aggregate then + Expand_Atomic_Aggregate (Expr, Etype (E)); + + -- If the expression is a reference to a record or array + -- object entity, then reset Is_True_Constant to False so + -- that the compiler will not optimize away the intermediate + -- object, which we need in this case for the same reason + -- (to ensure that the actual assignment is atomic, rather + -- than component-wise). + + elsif Is_Entity_Name (Expr) + and then (Is_Record_Type (Etype (Expr)) + or else + Is_Array_Type (Etype (Expr))) + then + Set_Is_True_Constant (Entity (Expr), False); + end if; + end; end if; -- For a subprogram, freeze all parameter types and also the return - -- type (RM 13.14(13)). However skip this for internal subprograms. + -- type (RM 13.14(14)). However skip this for internal subprograms. -- This is also the point where any extra formal parameters are -- created since we now know whether the subprogram will use -- a foreign convention. if Is_Subprogram (E) then - if not Is_Internal (E) then - declare F_Type : Entity_Id; @@ -1627,7 +1976,6 @@ package body Freeze is Formal := First_Formal (E); while Present (Formal) loop - F_Type := Etype (Formal); Freeze_And_Append (F_Type, Loc, Result); @@ -1643,6 +1991,7 @@ package body Freeze is -- an artifact of our need to regard the end of an -- instantiation as a freeze point. Otherwise it is -- a definite error. + -- and then not Is_Wrapper_Package (Current_Scope) ??? if In_Instance then @@ -1659,7 +2008,9 @@ package body Freeze is -- Check bad use of fat C pointer - if Is_Fat_C_Ptr_Type (F_Type) then + if Warn_On_Export_Import and then + Is_Fat_C_Ptr_Type (F_Type) + then Error_Msg_Qual_Level := 1; Error_Msg_N ("?type of & does not correspond to C pointer", @@ -1674,6 +2025,7 @@ package body Freeze is and then not Is_Imported (E) and then Is_Array_Type (F_Type) and then not Is_Constrained (F_Type) + and then Warn_On_Export_Import then Error_Msg_Qual_Level := 1; Error_Msg_N @@ -1693,7 +2045,9 @@ package body Freeze is if Ekind (E) = E_Function then Freeze_And_Append (Etype (E), Loc, Result); - if Is_Fat_C_Ptr_Type (Etype (E)) then + if Warn_On_Export_Import + and then Is_Fat_C_Ptr_Type (Etype (E)) + then Error_Msg_N ("?return type of& does not correspond to C pointer", E); @@ -1702,9 +2056,10 @@ package body Freeze is and then not Is_Constrained (Etype (E)) and then not Is_Imported (E) and then Convention (E) in Foreign_Convention + and then Warn_On_Export_Import then Error_Msg_N - ("foreign convention function may not " & + ("?foreign convention function& should not " & "return unconstrained array", E); end if; end if; @@ -1751,6 +2106,7 @@ package body Freeze is if Nkind (Declaration_Node (E)) = N_Object_Declaration then Validate_Object_Declaration (Declaration_Node (E)); + Check_Address_Clause (E); end if; -- Check that a constant which has a pragma Volatile[_Components] @@ -1829,13 +2185,13 @@ package body Freeze is Freeze_And_Append (Atype, Loc, Result); -- Otherwise freeze the base type of the entity before - -- freezing the entity itself, (RM 13.14(14)). + -- freezing the entity itself, (RM 13.14(15)). elsif E /= Base_Type (E) then Freeze_And_Append (Base_Type (E), Loc, Result); end if; - -- For a derived type, freeze its parent type first (RM 13.14(14)) + -- 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); @@ -1843,11 +2199,12 @@ package body Freeze is end if; -- For array type, freeze index types and component type first - -- before freezing the array (RM 13.14(14)). + -- before freezing the array (RM 13.14(15)). if Is_Array_Type (E) then declare - Ctyp : constant Entity_Id := Component_Type (E); + Ctyp : constant Entity_Id := Component_Type (E); + Pnod : Node_Id; Non_Standard_Enum : Boolean := False; -- Set true if any of the index types is an enumeration @@ -1949,6 +2306,33 @@ package body Freeze is Set_Component_Size (Base_Type (E), Csiz); + -- Check for base type of 8,16,32 bits, where the + -- subtype has a length one less than the base type + -- and is unsigned (e.g. Natural subtype of Integer) + + -- In such cases, if a component size was not set + -- explicitly, then generate a warning. + + if Has_Pragma_Pack (E) + and then not Has_Component_Size_Clause (E) + and then + (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then Esize (Base_Type (Ctyp)) = Csiz + 1 + then + Error_Msg_Uint_1 := Csiz; + Pnod := + Get_Rep_Pragma (First_Subtype (E), Name_Pack); + + if Present (Pnod) then + Error_Msg_N + ("pragma Pack causes component size to be ^?", + Pnod); + Error_Msg_N + ("\use Component_Size to set desired value", + Pnod); + end if; + end if; + -- Actual packing is not needed for 8,16,32,64 -- Also not needed for 24 if alignment is 1 @@ -2000,18 +2384,19 @@ package body Freeze is -- we can give a better error message in those cases that -- we do catch with the circuitry here. - if Present (Size_Clause (E)) - and then Known_Static_Esize (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_Component_Size (E) - then - declare - Lo, Hi : Node_Id; - Ctyp : constant Entity_Id := Component_Type (E); + declare + Lo, Hi : Node_Id; + Ctyp : constant Entity_Id := Component_Type (E); - begin + begin + if Present (Size_Clause (E)) + and then Known_Static_Esize (E) + and then not Is_Bit_Packed_Array (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) + then Get_Index_Bounds (First_Index (E), Lo, Hi); if Compile_Time_Known_Value (Lo) @@ -2020,14 +2405,22 @@ package body Freeze is and then RM_Size (Ctyp) < 64 then declare - Lov : constant Uint := Expr_Value (Lo); - Hiv : constant Uint := Expr_Value (Hi); - Len : constant Uint := - UI_Max (Uint_0, Hiv - Lov + 1); + Lov : constant Uint := Expr_Value (Lo); + Hiv : constant Uint := Expr_Value (Hi); + Len : constant Uint := + UI_Max (Uint_0, Hiv - Lov + 1); + Rsiz : constant Uint := RM_Size (Ctyp); + + -- What we are looking for here is the situation + -- where the Esize given would be exactly right + -- if there was a pragma Pack (resulting in the + -- component size being the same as the RM_Size). + -- Furthermore, the component type size must be + -- an odd size (not a multiple of storage unit) begin - if Esize (E) < Len * Component_Size (E) - and then Esize (E) = Len * RM_Size (Ctyp) + if Esize (E) = Len * Rsiz + and then Rsiz mod System_Storage_Unit /= 0 then Error_Msg_NE ("size given for& too small", @@ -2038,8 +2431,8 @@ package body Freeze is end if; end; end if; - end; - end if; + end if; + end; -- If any of the index types was an enumeration type with -- a non-standard rep clause, then we indicate that the @@ -2071,8 +2464,8 @@ package body Freeze is Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); end if; - -- For a class wide type, the corresponding specific type is - -- frozen as well (RM 13.14(14)) + -- For a class-wide type, the corresponding specific type is + -- frozen as well (RM 13.14(15)) elsif Is_Class_Wide_Type (E) then Freeze_And_Append (Root_Type (E), Loc, Result); @@ -2086,9 +2479,8 @@ package body Freeze is if Is_Itype (E) and then Is_Compilation_Unit (Scope (E)) then - declare - Ref : Node_Id := Make_Itype_Reference (Loc); + Ref : constant Node_Id := Make_Itype_Reference (Loc); begin Set_Itype (Ref, E); @@ -2100,8 +2492,20 @@ package body Freeze is end; end if; - -- For record (sub)type, freeze all the component types (RM - -- 13.14(14). We test for E_Record_(sub)Type here, rather than + -- The equivalent type associated with a class-wide subtype + -- needs to be frozen to ensure that its layout is done. + -- Class-wide subtypes are currently only frozen on targets + -- requiring front-end layout (see New_Class_Wide_Subtype + -- and Make_CW_Equivalent_Type in exp_util.adb). + + if Ekind (E) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (E)) + then + Freeze_And_Append (Equivalent_Type (E), Loc, Result); + end if; + + -- For a record (sub)type, freeze all the component types (RM + -- 13.14(15). We test for E_Record_(sub)Type here, rather than -- using Is_Record_Type, because we don't want to attempt the -- freeze for the case of a private type with record extension -- (we will do that later when the full type is frozen). @@ -2146,7 +2550,7 @@ package body Freeze is -- end of a scope (or within the scope of the private type), -- the partial and full views will have been swapped, the -- full view appears first in the entity chain and the swapping - -- mechanism enusres that the pointers are properly set (on + -- mechanism ensures that the pointers are properly set (on -- scope exit). -- If we encounter the partial view before the full view @@ -2172,31 +2576,39 @@ package body Freeze is Check_Debug_Info_Needed (E); -- Otherwise freeze full view and patch the pointers + -- so that the freeze node will elaborate both views + -- in the back-end. else - if Is_Private_Type (Full_View (E)) - and then Present (Underlying_Full_View (Full_View (E))) - then - Freeze_And_Append - (Underlying_Full_View (Full_View (E)), Loc, Result); - end if; + declare + Full : constant Entity_Id := Full_View (E); - Freeze_And_Append (Full_View (E), Loc, Result); + begin + if Is_Private_Type (Full) + and then Present (Underlying_Full_View (Full)) + then + Freeze_And_Append + (Underlying_Full_View (Full), Loc, Result); + end if; - if Has_Delayed_Freeze (E) then - F_Node := Freeze_Node (Full_View (E)); + Freeze_And_Append (Full, Loc, Result); - if Present (F_Node) then - Set_Freeze_Node (E, F_Node); - Set_Entity (F_Node, E); - else - -- {Incomplete,Private}_Subtypes - -- with Full_Views constrained by discriminants + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Full); - Set_Has_Delayed_Freeze (E, False); - Set_Freeze_Node (E, Empty); + if Present (F_Node) then + Set_Freeze_Node (E, F_Node); + Set_Entity (F_Node, E); + + else + -- {Incomplete,Private}_Subtypes + -- with Full_Views constrained by discriminants + + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; end if; - end if; + end; Check_Debug_Info_Needed (E); end if; @@ -2290,6 +2702,37 @@ package body Freeze is if Is_Fixed_Point_Type (E) then Freeze_Fixed_Point_Type (E); + -- Some error checks required for ordinary fixed-point type. + -- Defer 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 Small_Value (E) < Ureal_2_M_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` is too small, minimum is 2.0'*'*(-80)", E); + + elsif Small_Value (E) > Ureal_2_80 then + Error_Msg_Name_1 := Name_Small; + Error_Msg_N + ("`&''%` is too large, maximum is 2.0'*'*80", E); + end if; + + if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then + Error_Msg_Name_1 := Name_First; + Error_Msg_N + ("`&''%` is too small, minimum is -10.0'*'*36", E); + end if; + + if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then + Error_Msg_Name_1 := Name_Last; + Error_Msg_N + ("`&''%` is too large, maximum is 10.0'*'*36", E); + end if; + end if; + elsif Is_Enumeration_Type (E) then Freeze_Enumeration_Type (E); @@ -2309,7 +2752,6 @@ package body Freeze is if Is_Composite_Type (E) then if Is_Array_Type (E) then - declare Index : Node_Id := First_Index (E); Expr1 : Node_Id; @@ -2347,9 +2789,7 @@ package body Freeze is begin Constraint := First_Elmt (Discriminant_Constraint (E)); - while Present (Constraint) loop - Expr := Node (Constraint); if Nkind (Expr) = N_Identifier and then Ekind (Entity (Expr)) = E_Discriminant @@ -2363,7 +2803,6 @@ package body Freeze is Next_Elmt (Constraint); end loop; end; - end if; -- AI-117 requires that all new primitives of a tagged type @@ -2386,7 +2825,6 @@ package body Freeze is declare Prim_List : constant Elist_Id := Primitive_Operations (E); Prim : Elmt_Id; - begin Prim := First_Elmt (Prim_List); while Present (Prim) loop @@ -2512,7 +2950,6 @@ package body Freeze is else Append (F_Node, Result); end if; - end if; -- When a type is frozen, the first subtype of the type is frozen as @@ -2565,7 +3002,6 @@ package body Freeze is Generate_Subprogram_Descriptor_For_Imported_Subprogram (E, Result); end if; - end if; return Result; @@ -2582,7 +3018,6 @@ package body Freeze is and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); - else Adjust_Esize_For_Alignment (Typ); end if; @@ -2614,6 +3049,10 @@ package body Freeze is -- subprogram (init proc, or stream subprogram). If so, it returns -- True, otherwise False. + ----------------- + -- In_Exp_Body -- + ----------------- + function In_Exp_Body (N : Node_Id) return Boolean is P : Node_Id; @@ -2631,18 +3070,17 @@ package body Freeze is P := Defining_Unit_Name (Specification (P)); if Nkind (P) = N_Defining_Identifier - and then (Chars (P) = Name_uInit_Proc or else - Chars (P) = Name_uInput or else - Chars (P) = Name_uOutput or else - Chars (P) = Name_uRead or else - Chars (P) = Name_uWrite) + and then (Is_Init_Proc (P) or else + Is_TSS (P, TSS_Stream_Input) or else + Is_TSS (P, TSS_Stream_Output) or else + Is_TSS (P, TSS_Stream_Read) or else + Is_TSS (P, TSS_Stream_Write)) then return True; else return False; end if; end if; - end In_Exp_Body; -- Start of processing for Freeze_Expression @@ -2672,12 +3110,18 @@ package body Freeze is -- Freeze type of expression if not frozen already - if Nkind (N) in N_Has_Etype - and then not Is_Frozen (Etype (N)) - then - Typ := Etype (N); - else - Typ := Empty; + Typ := Empty; + + if Nkind (N) in N_Has_Etype then + if not Is_Frozen (Etype (N)) then + Typ := Etype (N); + + -- Base type may be an derived numeric type that is frozen at + -- the point of declaration, but first_subtype is still unfrozen. + + elsif not Is_Frozen (First_Subtype (Etype (N))) then + Typ := First_Subtype (Etype (N)); + end if; end if; -- For entity name, freeze entity if not frozen already. A special @@ -2695,7 +3139,6 @@ package body Freeze is or else not Comes_From_Source (Entity (N))) then Nam := Entity (N); - else Nam := Empty; end if; @@ -2709,8 +3152,8 @@ package body Freeze is -- expression cannot contain an allocator, so the type is not frozen. Desig_Typ := Empty; - case Nkind (N) is + case Nkind (N) is when N_Allocator => Desig_Typ := Designated_Type (Etype (N)); @@ -2731,7 +3174,6 @@ package body Freeze is when others => null; - end case; if Desig_Typ /= Empty @@ -2813,7 +3255,7 @@ package body Freeze is -- If we have an enumeration literal that appears as the -- choice in the aggregate of an enumeration representation - -- clause, then freezing does not occur (RM 13.14(9)). + -- clause, then freezing does not occur (RM 13.14(10)). when N_Enumeration_Representation_Clause => @@ -3002,7 +3444,6 @@ package body Freeze is end if; if Is_Non_Empty_List (Freeze_Nodes) then - if No (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions) then @@ -3031,20 +3472,20 @@ package body Freeze is In_Default_Expression := False; - -- Freeze the designated type of an allocator (RM 13.14(12)) + -- Freeze the designated type of an allocator (RM 13.14(13)) if Present (Desig_Typ) then Freeze_Before (P, Desig_Typ); end if; - -- Freeze type of expression (RM 13.14(9)). Note that we took care of + -- Freeze type of expression (RM 13.14(10)). Note that we took care of -- the enumeration representation clause exception in the loop above. if Present (Typ) then Freeze_Before (P, Typ); end if; - -- Freeze name if one is present (RM 13.14(10)) + -- Freeze name if one is present (RM 13.14(11)) if Present (Nam) then Freeze_Before (P, Nam); @@ -3102,9 +3543,9 @@ package body Freeze is Atype := Ancestor_Subtype (Typ); if Present (Atype) then - Set_Size_Info (Typ, Atype); + Set_Esize (Typ, Esize (Atype)); else - Set_Size_Info (Typ, Base_Type (Typ)); + Set_Esize (Typ, Esize (Base_Type (Typ))); end if; end if; @@ -3462,9 +3903,11 @@ package body Freeze is Set_Etype (Rng, Etype (Lo)); - -- Set Esize to calculated size and also set RM_Size + -- Set Esize to calculated size if not set already - Init_Esize (Typ, Actual_Size); + if Unknown_Esize (Typ) then + Init_Esize (Typ, Actual_Size); + end if; -- Set RM_Size if not already set. If already set, check value @@ -3485,7 +3928,6 @@ package body Freeze is Set_RM_Size (Typ, Minsiz); end if; end; - end Freeze_Fixed_Point_Type; ------------------ @@ -3652,6 +4094,14 @@ package body Freeze is begin Ensure_Type_Is_SA (Etype (E)); + -- Reset True_Constant flag, since something strange is going on + -- with the scoping here, and our simple value traceing may not + -- be sufficient for this indication to be reliable. We kill the + -- Constant_Value indication for the same reason. + + Set_Is_True_Constant (E, False); + Set_Current_Value (E, Empty); + exception when Cannot_Be_Static => @@ -3706,6 +4156,7 @@ package body Freeze is if Ekind (E) = E_Procedure and then Is_Valued_Procedure (E) and then Convention (E) = Convention_Ada + and then Warn_On_Export_Import then Error_Msg_N ("?Valued_Procedure has no effect for convention Ada", E); @@ -3717,7 +4168,7 @@ package body Freeze is else Set_Mechanisms (E); - -- For foreign conventions, do not permit return of an + -- For foreign conventions, warn about return of an -- unconstrained array. -- Note: we *do* allow a return by descriptor for the VMS case, @@ -3742,10 +4193,11 @@ package body Freeze is elsif Is_Array_Type (Retype) and then not Is_Constrained (Retype) and then Mechanism (E) not in Descriptor_Codes + and then Warn_On_Export_Import then - Error_Msg_NE - ("convention for& does not permit returning " & - "unconstrained array type", E, E); + Error_Msg_N + ("?foreign convention function& should not return " & + "unconstrained array", E); return; end if; end if; @@ -3757,7 +4209,9 @@ package body Freeze is if Is_Exported (E) then F := First_Formal (E); while Present (F) loop - if Present (Default_Value (F)) then + if Warn_On_Export_Import + and then Present (Default_Value (F)) + then Error_Msg_N ("?parameter cannot be defaulted in non-Ada call", Default_Value (F)); @@ -3786,7 +4240,6 @@ package body Freeze is end loop; end if; end if; - end Freeze_Subprogram; ----------------------- @@ -3862,7 +4315,6 @@ package body Freeze is or else (Nkind (Dcopy) = N_Attribute_Reference and then Attribute_Name (Dcopy) = Name_Null_Parameter) - then -- If there is no default function, we must still do a full @@ -3884,7 +4336,7 @@ package body Freeze is -- context is generic, to avoid anomalies with private types. if Ekind (Scope (E)) = E_Generic_Package then - Resolve (Dcopy, Etype (Dcopy)); + Resolve (Dcopy); else Resolve (Dcopy, Etype (Formal)); end if; @@ -4035,7 +4487,134 @@ package body Freeze is Set_Debug_Info_Needed (Corresponding_Record_Type (T)); end if; end if; - end Set_Debug_Info_Needed; + ------------------ + -- Warn_Overlay -- + ------------------ + + procedure Warn_Overlay + (Expr : Node_Id; + Typ : Entity_Id; + Nam : Entity_Id) + is + Ent : constant Entity_Id := Entity (Nam); + -- The object to which the address clause applies. + + Init : Node_Id; + Old : Entity_Id := Empty; + Decl : Node_Id; + + begin + -- No warning if address clause overlay warnings are off + + if not Address_Clause_Overlay_Warnings then + return; + end if; + + -- No warning if there is an explicit initialization + + Init := Original_Node (Expression (Declaration_Node (Ent))); + + if Present (Init) and then Comes_From_Source (Init) then + return; + end if; + + -- We only give the warning for non-imported entities of a type + -- for which a non-null base init proc is defined (or for access + -- types which have implicit null initialization). + + if Present (Expr) + and then (Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Access_Type (Typ)) + and then not Is_Imported (Ent) + then + if Nkind (Expr) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Expr)) + then + Old := Entity (Prefix (Expr)); + + elsif Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Decl := Declaration_Node (Entity (Expr)); + + if Nkind (Decl) = N_Object_Declaration + and then Present (Expression (Decl)) + and then Nkind (Expression (Decl)) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Expression (Decl))) + then + Old := Entity (Prefix (Expression (Decl))); + + elsif Nkind (Expr) = N_Function_Call then + return; + end if; + + -- A function call (most likely to To_Address) is probably not + -- an overlay, so skip warning. Ditto if the function call was + -- inlined and transformed into an entity. + + elsif Nkind (Original_Node (Expr)) = N_Function_Call then + return; + end if; + + Decl := Next (Parent (Expr)); + + -- If a pragma Import follows, we assume that it is for the current + -- target of the address clause, and skip the warning. + + if Present (Decl) + and then Nkind (Decl) = N_Pragma + and then Chars (Decl) = Name_Import + then + return; + end if; + + if Present (Old) then + Error_Msg_Node_2 := Old; + Error_Msg_N + ("default initialization of & may modify &?", + Nam); + else + Error_Msg_N + ("default initialization of & may modify overlaid storage?", + Nam); + end if; + + -- Add friendly warning if initialization comes from a packed array + -- component. + + if Is_Record_Type (Typ) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + + while Present (Comp) loop + if Nkind (Parent (Comp)) = N_Component_Declaration + and then Present (Expression (Parent (Comp))) + then + exit; + elsif Is_Array_Type (Etype (Comp)) + and then Present (Packed_Array_Type (Etype (Comp))) + then + Error_Msg_NE + ("packed array component& will be initialized to zero?", + Nam, Comp); + exit; + else + Next_Component (Comp); + end if; + end loop; + end; + end if; + + Error_Msg_N + ("use pragma Import for & to " & + "suppress initialization ('R'M B.1(24))?", + Nam); + end if; + end Warn_Overlay; + end Freeze; |