+2016-10-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/77968
+ * gcc-interface/utils.c (create_var_decl): Do not clear TREE_READONLY
+ in LTO mode for an external variable.
+ (can_materialize_object_renaming_p): Move up.
+
2016-10-13 Thomas Preud'homme <thomas.preudhomme@arm.com>
* gcc-interface/utils2.c: Include memmodel.h.
constant initialization and save any variable elaborations for the
elaboration routine. If we are just annotating types, throw away the
initialization if it isn't a constant. */
- if ((extern_flag && init && !constant_p)
+ if ((extern_flag && !constant_p)
|| (type_annotate_only && init && !TREE_CONSTANT (init)))
- {
- init = NULL_TREE;
-
- /* In LTO mode, also clear TREE_READONLY the same way add_decl_expr
- would do it if the initializer was not thrown away here, as the
- WPA phase requires a consistent view across compilation units. */
- if (const_flag && flag_generate_lto)
- {
- const_flag = false;
- DECL_READONLY_ONCE_ELAB (var_decl) = 1;
- }
- }
+ init = NULL_TREE;
/* At the global level, a non-constant initializer generates elaboration
statements. Check that such statements are allowed, that is to say,
return tree_int_cst_lt (size, osize) != 0;
}
+/* Return whether EXPR, which is the renamed object in an object renaming
+ declaration, can be materialized as a reference (with a REFERENCE_TYPE).
+ This should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
+
+bool
+can_materialize_object_renaming_p (Node_Id expr)
+{
+ while (true)
+ {
+ switch Nkind (expr)
+ {
+ case N_Identifier:
+ case N_Expanded_Name:
+ return true;
+
+ case N_Selected_Component:
+ {
+ if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
+ return false;
+
+ const Uint bitpos
+ = Normalized_First_Bit (Entity (Selector_Name (expr)));
+ if (!UI_Is_In_Int_Range (bitpos)
+ || (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
+ return false;
+
+ expr = Prefix (expr);
+ break;
+ }
+
+ case N_Indexed_Component:
+ case N_Slice:
+ {
+ const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
+
+ if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
+ return false;
+
+ expr = Prefix (expr);
+ break;
+ }
+
+ case N_Explicit_Dereference:
+ expr = Prefix (expr);
+ break;
+
+ default:
+ return true;
+ };
+ }
+}
+
/* Perform final processing on global declarations. */
static GTY (()) tree dummy_global;
return NULL_TREE;
}
-/* Return whether EXPR, which is the renamed object in an object renaming
- declaration, can be materialized as a reference (REFERENCE_TYPE). This
- should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
-
-bool
-can_materialize_object_renaming_p (Node_Id expr)
-{
- while (true)
- {
- switch Nkind (expr)
- {
- case N_Identifier:
- case N_Expanded_Name:
- return true;
-
- case N_Selected_Component:
- {
- if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
- return false;
-
- const Uint bitpos
- = Normalized_First_Bit (Entity (Selector_Name (expr)));
- if (!UI_Is_In_Int_Range (bitpos)
- || (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
- return false;
-
- expr = Prefix (expr);
- break;
- }
-
- case N_Indexed_Component:
- case N_Slice:
- {
- const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
-
- if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
- return false;
-
- expr = Prefix (expr);
- break;
- }
-
- case N_Explicit_Dereference:
- expr = Prefix (expr);
- break;
-
- default:
- return true;
- };
- }
-}
-
/* ----------------------------------------------------------------------- *
* BUILTIN FUNCTIONS *
* ----------------------------------------------------------------------- */
+2016-10-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat.dg/lto15.adb: Adjust.
+ * gnat.dg/lto16.adb: Likewise.
+ * gnat.dg/lto17.adb: Likewise
+ * gnat.dg/lto18.ad[sb]: New test.
+ * gnat.dg/lto18_pkg.ads: New helper.
+ * gnat.dg/lto19.adb: New test.
+ * gnat.dg/lto19_pkg1.ad[sb]: New helper.
+ * gnat.dg/lto19_pkg2.ad[sb]: Likewise.
+ * gnat.dg/lto20.adb: New test.
+ * gnat.dg/lto20_pkg.ad[sb]: New helper.
+
2016-10-14 Andre Vehreschild <vehre@gcc.gnu.org>
* gfortran.dg/coarray_38.f90: Expect error message.
-- { dg-do compile }
--- { dg-options "-O -flto -g" }
--- { dg-require-effective-target lto }
+-- { dg-options "-O -flto -g" { target lto } }
package body Lto15 is
-- { dg-do link }
--- { dg-options "-O -flto" }
--- { dg-require-effective-target lto }
+-- { dg-options "-O -flto" { target lto } }
with Lto16_Pkg; use Lto16_Pkg;
with Text_IO; use Text_IO;
-- { dg-do compile }
--- { dg-options "-flto" }
--- { dg-require-effective-target lto }
+-- { dg-options "-flto" { target lto } }
package body Lto17 is
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-flto" { target lto } }
+
+package body Lto18 is
+
+ procedure Proc (Driver : Rec) is
+ R : Path;
+ begin
+ for I in Driver.Step'Range loop
+ R := Get (Driver, 1, Driver.Step (I));
+ R := Get (Driver, 2, Driver.Step (I));
+ R := Get (Driver, 3, Driver.Step (I));
+ end loop;
+ end;
+
+end Lto18;
--- /dev/null
+with Lto18_Pkg; use Lto18_Pkg;
+
+package Lto18 is
+
+ procedure Proc (Driver : Rec);
+
+end Lto18;
--- /dev/null
+package Lto18_Pkg is
+
+ function N return Positive;
+ pragma Import (Ada, N);
+
+ type Path is array(1 .. N) of Long_Float;
+ type Path_Vector is array (Positive range <>) of Path;
+ type Path_Vector_P is access all Path_Vector;
+ type Path_Vector_PV is array(Positive range <>) of Path_Vector_P;
+ type Path_Vector_P2 is access all Path_Vector_PV;
+
+ type Vector is array (Positive range <>) of Natural;
+ type Vector_Access is access Vector;
+
+ type Rec is record
+ Val : Path_Vector_P2;
+ Step : Vector_Access;
+ end record;
+
+ function Get (R : Rec; I : Positive; M : Natural) return Path;
+-- pragma Inline (Get);
+
+end Lto18_Pkg;
--- /dev/null
+-- { dg-do run }
+-- { dg-options "-flto" { target lto } }
+-- { dg-excess-errors "does not match original declaration" }
+
+with Lto19_Pkg1;
+
+procedure Lto19 is
+ R : Lto19_Pkg1.Rec := (I => 1, A => (others => 0));
+begin
+ Lto19_Pkg1.Proc (R);
+end;
--- /dev/null
+package body Lto19_Pkg1 is
+
+ procedure Proc (R : Rec) is begin null; end;
+
+end Lto19_Pkg1;
--- /dev/null
+with Lto19_Pkg2;
+
+package Lto19_Pkg1 is
+
+ type Arr is array (1 .. Lto19_Pkg2.UB) of Integer;
+
+ type Rec is record
+ A : Arr;
+ I : Integer;
+ end record;
+
+ procedure Proc (R : Rec);
+
+end Lto19_Pkg1;
--- /dev/null
+package body Lto19_Pkg2 is
+
+ function UB return Natural is begin return 8; end;
+
+end Lto19_Pkg2;
--- /dev/null
+package Lto19_Pkg2 is
+
+ function UB return Natural;
+
+end Lto19_Pkg2;
--- /dev/null
+-- { dg-do run }
+-- { dg-options "-flto" { target lto } }
+-- { dg-excess-errors "does not match original declaration" }
+
+with Lto20_Pkg;
+
+procedure Lto20 is
+begin
+ Lto20_Pkg.Proc (Lto20_Pkg.Null_Arr);
+end;
--- /dev/null
+package body Lto20_Pkg is
+
+ type Obj is record
+ I : Integer;
+ end record;
+
+ procedure Proc (A : Arr) is begin null; end;
+
+end Lto20_Pkg;
--- /dev/null
+package Lto20_Pkg is
+
+ type Arr is private;
+
+ Null_Arr : constant Arr;
+
+ procedure Proc (A : Arr);
+
+private
+
+ type Obj;
+
+ type Handle is access Obj;
+
+ Null_Handle : constant Handle := null;
+
+ type Arr is array (1 .. 2) of Handle;
+
+ Null_Arr : constant Arr := (others => Null_Handle);
+
+end Lto20_Pkg;
projects / gcc.git / commitdiff