+2015-01-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Has_Independent_Components): Document extended
+ usage.
+ * einfo.adb (Has_Independent_Components): Remove obsolete assertion.
+ (Set_Has_Independent_Components): Adjust assertion.
+ * sem_prag.adb (Analyze_Pragma): Also set Has_Independent_Components
+ for pragma Atomic_Components. Set Has_Independent_Components
+ on the object instead of the type for an object declaration with
+ pragma Independent_Components.
+
+2015-01-06 Olivier Hainque <hainque@adacore.com>
+
+ * set_targ.adb (Read_Target_Dependent_Values): Set
+ Long_Double_Index when "long double" is read.
+ (elaboration code): Register_Back_End_Types only when not reading from
+ config files. Doing otherwise is pointless and error prone.
+
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * s-valrea.adb (Value_Real): Check for Str'Last = Positive'Last
+
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * a-wtgeau.adb, a-ztgeau.adb, a-tigeau.adb (String_Skip): Raise PE if
+ Str'Last = Positive'Last.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Matches_Limited_View): Handle properly the case
+ where the non-limited type is a generic actual and appears as
+ a subtype of the non-limited view of the other.
+ * freeze.adb (Build_Renamed_Body): If the return type of the
+ declaration that is being completed is a limited view and the
+ non-limited view is available, use it in the specification of
+ the generated body.
+
+2015-01-06 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb: Reapplying reversed patch.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Find_Type_Name): If there is a previous tagged
+ incomplete view, the type of the classwide type common to both
+ views is the type being declared.
+
2015-01-06 Eric Botcazou <ebotcazou@adacore.com>
* einfo.ads (Is_Independent): Further document extended usage.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
+ -- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
+ -- It's too much trouble to make this silly case work, so we just raise
+ -- Program_Error with an appropriate message. We raise Program_Error
+ -- rather than Constraint_Error because we don't want this case to be
+ -- converted to Data_Error.
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
+ -- Normal case where Str'Last < Positive'Last
+
Ptr := Str'First;
loop
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
+ -- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
+ -- It's too much trouble to make this silly case work, so we just raise
+ -- Program_Error with an appropriate message. We raise Program_Error
+ -- rather than Constraint_Error because we don't want this case to be
+ -- converted to Data_Error.
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
+ -- Normal case where Str'Last < Positive'Last
+
Ptr := Str'First;
loop
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
+ -- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
+ -- It's too much trouble to make this silly case work, so we just raise
+ -- Program_Error with an appropriate message. We raise Program_Error
+ -- rather than Constraint_Error because we don't want this case to be
+ -- converted to Data_Error.
+
+ if Str'Last = Positive'Last then
+ raise Program_Error with
+ "string upper bound is Positive'Last, not supported";
+ end if;
+
+ -- Normal case where Str'Last < Positive'Last
+
Ptr := Str'First;
loop
function Has_Independent_Components (Id : E) return B is
begin
- pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
- return Flag34 (Base_Type (Id));
+ return Flag34 (Implementation_Base_Type (Id));
end Has_Independent_Components;
function Has_Inheritable_Invariants (Id : E) return B is
procedure Set_Has_Independent_Components (Id : E; V : B := True) is
begin
- pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Is_Base_Type (Id));
+ pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag34 (Id, V);
end Set_Has_Independent_Components;
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
--- Has_Independent_Components (Flag34) [base type only]
--- Defined in types. Set if the aspect Independent_Components applies
--- (in the base type only), if corresponding pragma or aspect applies.
--- In the case of an object of anonymous array type, the flag is set on
--- the created array type.
+-- Has_Independent_Components (Flag34) [implementation base type only]
+-- Defined in all types and objects. Set only for a record type or an
+-- array type or array object if a valid pragma Independent_Components
+-- applies to the type or object. Note that in the case of an object,
+-- this flag is only set on the object if there was an explicit pragma
+-- for the object. In other words, the proper test for whether an object
+-- has independent components is to see if either the object or its base
+-- type has this flag set. Note that in the case of a type, the pragma
+-- will be chained to the rep item chain of the first subtype in the
+-- usual manner.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
+ -- Has_Independent_Components (Flag34)
-- Has_Thunks (Flag228) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
+ -- Has_Independent_Components (Flag34)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
+ -- No displacement of the pointer to the object needed when the type of
+ -- the operand is not an interface type and the interface is one of
+ -- its parent types (since they share the primary dispatch table).
+
+ declare
+ Opnd : Entity_Id := Operand_Typ;
+
+ begin
+ if Is_Access_Type (Opnd) then
+ Opnd := Designated_Type (Opnd);
+ end if;
+
+ if not Is_Interface (Opnd)
+ and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
+ then
+ return;
+ end if;
+ end;
+
-- Evaluate if we can statically displace the pointer to the object
declare
Set_Body_To_Inline (Decl, Old_S);
end if;
+ -- Check whether the return type is a limited view. If the subprogram
+ -- is already frozen the generated body may have a non-limited view
+ -- of the type, that must be used, because it is the one in the spec
+ -- of the renaming declaration.
+
+ if Ekind (Old_S) = E_Function
+ and then Is_Entity_Name (Result_Definition (Spec))
+ then
+ declare
+ Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec));
+ begin
+ if Ekind (Ret_Type) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Ret_Type))
+ then
+ Set_Result_Definition (Spec,
+ New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc));
+ end if;
+ end;
+ end if;
+
-- The body generated for this renaming is an internal artifact, and
-- does not constitute a freeze point for the called entity.
----------------
function Value_Real (Str : String) return Long_Long_Float is
- V : Long_Long_Float;
- P : aliased Integer := Str'First;
begin
- V := Scan_Real (Str, P'Access, Str'Last);
- Scan_Trailing_Blanks (Str, P);
- return V;
+ -- We have to special case Str'Last = Positive'Last because the normal
+ -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
+ -- deal with this by converting to a subtype which fixes the bounds.
+
+ if Str'Last = Positive'Last then
+ declare
+ subtype NT is String (1 .. Str'Length);
+ begin
+ return Value_Real (NT (Str));
+ end;
+
+ -- Normal case where Str'Last < Positive'Last
+
+ else
+ declare
+ V : Long_Long_Float;
+ P : aliased Integer := Str'First;
+ begin
+ V := Scan_Real (Str, P'Access, Str'Last);
+ Scan_Trailing_Blanks (Str, P);
+ return V;
+ end;
+ end if;
end Value_Real;
end System.Val_Real;
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- -- If the incomplete type is completed by a private declaration
- -- the class-wide type remains associated with the incomplete
- -- type, to prevent order-of-elaboration issues in gigi, else
- -- we associate the class-wide type with the known full view.
+ -- The type of the classwide type is the current Id. Previously
+ -- this was not done for private declarations because of order-
+ -- of elaboration issues in the back-end, but gigi now handles
+ -- this properly.
- if Nkind (N) /= N_Private_Type_Declaration then
- Set_Etype (Class_Wide_Type (Id), Id);
- end if;
+ Set_Etype (Class_Wide_Type (Id), Id);
end if;
-- Case of full declaration of private type
begin
-- In some cases a type imported through a limited_with clause, and
-- its nonlimited view are both visible, for example in an anonymous
- -- access-to-class-wide type in a formal. Both entities designate the
- -- same type.
-
- if From_Limited_With (T1) and then T2 = Available_View (T1) then
+ -- access-to-class-wide type in a formal, or when building the body
+ -- for a subprogram renaming after the subprogram has been frozen.
+ -- In these cases Both entities designate the same type. In addition,
+ -- if one of them is an actual in an instance, it may be a subtype of
+ -- the non-limited view of the other.
+
+ if From_Limited_With (T1)
+ and then (T2 = Available_View (T1)
+ or else Is_Subtype_Of (T2, Available_View (T1)))
+ then
return True;
- elsif From_Limited_With (T2) and then T1 = Available_View (T2) then
+ elsif From_Limited_With (T2)
+ and then (T1 = Available_View (T2)
+ or else Is_Subtype_Of (T1, Available_View (T2)))
+ then
return True;
elsif From_Limited_With (T1)
E := Base_Type (E);
end if;
- Set_Has_Volatile_Components (E);
+ -- Atomic implies both Independent and Volatile
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
+ Set_Has_Independent_Components (E);
end if;
+ Set_Has_Volatile_Components (E);
+
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
D := Declaration_Node (E);
K := Nkind (D);
+ -- The flag is set on the base type, or on the object
+
if K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E))
then
- Independence_Checks.Append ((N, Base_Type (E)));
Set_Has_Independent_Components (Base_Type (E));
+ Independence_Checks.Append ((N, Base_Type (E)));
-- For record type, set all components independent
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition
then
- Independence_Checks.Append ((N, Base_Type (Etype (E))));
- Set_Has_Independent_Components (Base_Type (Etype (E)));
+ Set_Has_Independent_Components (E);
+ Independence_Checks.Append ((N, E));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
-- type can be found if it gets registered at all.
Long_Double_Index : Integer := -1;
- -- Once all the back-end types have been registered, the index in
+ -- Once all the floating point types have been registered, the index in
-- FPT_Mode_Table at which "long double" can be found, if anywhere. A
-- negative value means that no "long double" has been registered. This
-- is useful to know whether we have a "long double" available at all and
begin
E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
+ if Long_Double_Index < 0 and then E.NAME.all = "long double" then
+ Long_Double_Index := Num_FPT_Modes;
+ end if;
+
E.DIGS := Get_Nat;
Check_Spaces;
end loop;
end;
- -- Register floating-point types from the back end. We do this
- -- unconditionally so C_Type_For may be called regardless of -gnateT, for
- -- which cstand has a use, and early so we can use FPT_Mode_Table below to
- -- compute some FP attributes.
-
- Register_Back_End_Types (Register_Float_Type'Access);
-
-- Case of reading the target dependent values from file
-- This is bit more complex than might be expected, because it has to be
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
- -- Compute the sizes of floating point types
+ -- Let the back-end register its floating point types and compute
+ -- the sizes of our standard types from there:
+
+ Num_FPT_Modes := 0;
+ Register_Back_End_Types (Register_Float_Type'Access);
declare
T : FPT_Mode_Entry renames
projects / gcc.git / commitdiff