diff options
Diffstat (limited to 'gcc/testsuite/gnat.dg')
85 files changed, 1674 insertions, 36 deletions
diff --git a/gcc/testsuite/gnat.dg/address_conv.adb b/gcc/testsuite/gnat.dg/address_conv.adb new file mode 100644 index 0000000000..27b3dada9a --- /dev/null +++ b/gcc/testsuite/gnat.dg/address_conv.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } + +with System.Storage_Elements; use System.Storage_Elements; + +procedure Address_Conv is + + subtype My_Address is System.Address; + + type Rec is record + A : My_Address; + end record; + + Addr : constant My_Address := To_Address (16#FACEFACE#); + + R : constant Rec := (A => Addr); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/array26.adb b/gcc/testsuite/gnat.dg/array26.adb new file mode 100644 index 0000000000..659d596fc1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array26.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Array26_Pkg; use Array26_Pkg; + +procedure Array26 is + + function Get return Outer_type is + Ret : Outer_Type; + begin + Ret (Inner_Type'Range) := F; + return Ret; + end; + + A : Outer_Type := Get; + B : Inner_Type := A (Inner_Type'Range); + +begin + if B /= "123" then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array26_pkg.adb b/gcc/testsuite/gnat.dg/array26_pkg.adb new file mode 100644 index 0000000000..f324bd2ce5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array26_pkg.adb @@ -0,0 +1,8 @@ +package body Array26_Pkg is + + function F return Inner_Type is + begin + return "123"; + end; + +end Array26_Pkg; diff --git a/gcc/testsuite/gnat.dg/array26_pkg.ads b/gcc/testsuite/gnat.dg/array26_pkg.ads new file mode 100644 index 0000000000..ae84a74725 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array26_pkg.ads @@ -0,0 +1,8 @@ +package Array26_Pkg is + + subtype Outer_Type is String (1 .. 4); + subtype Inner_Type is String (1 .. 3); + + function F return Inner_Type; + +end Array26_Pkg; diff --git a/gcc/testsuite/gnat.dg/array27.adb b/gcc/testsuite/gnat.dg/array27.adb new file mode 100644 index 0000000000..db821c5f82 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array27.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Array27_Pkg; use Array27_Pkg; + +procedure Array27 is + + function Get return Outer_type is + Ret : Outer_Type; + begin + Ret (Inner_Type'Range) := F; + return Ret; + end; + + A : Outer_Type := Get; + B : Inner_Type := A (Inner_Type'Range); + +begin + if B /= "123" then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array27_pkg.adb b/gcc/testsuite/gnat.dg/array27_pkg.adb new file mode 100644 index 0000000000..92c61b94a3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array27_pkg.adb @@ -0,0 +1,8 @@ +package body Array27_Pkg is + + function F return Inner_Type is + begin + return "123"; + end; + +end Array27_Pkg; diff --git a/gcc/testsuite/gnat.dg/array27_pkg.ads b/gcc/testsuite/gnat.dg/array27_pkg.ads new file mode 100644 index 0000000000..1473fbb446 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array27_pkg.ads @@ -0,0 +1,8 @@ +package Array27_Pkg is + + subtype Outer_Type is String (1 .. 8); + subtype Inner_Type is String (1 .. 3); + + function F return Inner_Type; + +end Array27_Pkg; diff --git a/gcc/testsuite/gnat.dg/array28.adb b/gcc/testsuite/gnat.dg/array28.adb new file mode 100644 index 0000000000..aa31445d37 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array28.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Array28_Pkg; use Array28_Pkg; + +procedure Array28 is + + function Get return Outer_type is + Ret : Outer_Type; + begin + Ret (Inner_Type'Range) := F; + return Ret; + end; + + A : Outer_Type := Get; + B : Inner_Type := A (Inner_Type'Range); + +begin + if B /= "12345" then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array28_pkg.adb b/gcc/testsuite/gnat.dg/array28_pkg.adb new file mode 100644 index 0000000000..726810b80f --- /dev/null +++ b/gcc/testsuite/gnat.dg/array28_pkg.adb @@ -0,0 +1,8 @@ +package body Array28_Pkg is + + function F return Inner_Type is + begin + return "12345"; + end; + +end Array28_Pkg; diff --git a/gcc/testsuite/gnat.dg/array28_pkg.ads b/gcc/testsuite/gnat.dg/array28_pkg.ads new file mode 100644 index 0000000000..6189010baf --- /dev/null +++ b/gcc/testsuite/gnat.dg/array28_pkg.ads @@ -0,0 +1,8 @@ +package Array28_Pkg is + + subtype Outer_Type is String (1 .. 8); + subtype Inner_Type is String (1 .. 5); + + function F return Inner_Type; + +end Array28_Pkg; diff --git a/gcc/testsuite/gnat.dg/biased_subtype.adb b/gcc/testsuite/gnat.dg/biased_subtype.adb new file mode 100644 index 0000000000..3833022963 --- /dev/null +++ b/gcc/testsuite/gnat.dg/biased_subtype.adb @@ -0,0 +1,20 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Biased_Subtype is + + CIM_Max_AA : constant := 9_999_999; + CIM_Min_AA : constant := -999_999; + + type TIM_AA is range CIM_Min_AA..CIM_Max_AA + 1; + for TIM_AA'Size use 24; + + subtype STIM_AA is TIM_AA range TIM_AA(CIM_Min_AA)..TIM_AA(CIM_Max_AA); + + SAA : STIM_AA := 1; + +begin + if Integer(SAA) /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/debug10.adb b/gcc/testsuite/gnat.dg/debug10.adb new file mode 100644 index 0000000000..5612b7874e --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug10.adb @@ -0,0 +1,68 @@ +-- PR debug/80321 + +-- { dg-do compile } +-- { dg-options "-O2 -g" } + +with Debug10_Pkg; use Debug10_Pkg; + +procedure Debug10 (T : Entity_Id) is + + procedure Inner (E : Entity_Id); + pragma Inline (Inner); + + procedure Inner (E : Entity_Id) is + begin + if E /= Empty + and then not Nodes (E + 3).Flag16 + then + Debug10 (E); + end if; + end Inner; + + function Ekind (E : Entity_Id) return Entity_Kind is + begin + return N_To_E (Nodes (E + 1).Nkind); + end Ekind; + +begin + + if T = Empty then + return; + end if; + + Nodes (T + 3).Flag16 := True; + + if Ekind (T) in Object_Kind then + Inner (T); + + elsif Ekind (T) in Type_Kind then + Inner (T); + + if Ekind (T) in Record_Kind then + + if Ekind (T) = E_Class_Wide_Subtype then + Inner (T); + end if; + + elsif Ekind (T) in Array_Kind then + Inner (T); + + elsif Ekind (T) in Access_Kind then + Inner (T); + + elsif Ekind (T) in Scalar_Kind then + + if My_Scalar_Range (T) /= Empty + and then My_Test (My_Scalar_Range (T)) + then + if My_Is_Entity_Name (T) then + Inner (T); + end if; + + if My_Is_Entity_Name (T) then + Inner (T); + end if; + end if; + end if; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/debug10_pkg.ads b/gcc/testsuite/gnat.dg/debug10_pkg.ads new file mode 100644 index 0000000000..10146c5a40 --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug10_pkg.ads @@ -0,0 +1,138 @@ +with Unchecked_Conversion; + +package Debug10_Pkg is + + type Node_Id is range 0 .. 99_999_999; + + Empty : constant Node_Id := 0; + + subtype Entity_Id is Node_Id; + + type Union_Id is new Integer; + + function My_Is_Entity_Name (N : Node_Id) return Boolean; + + function My_Scalar_Range (Id : Entity_Id) return Node_Id; + + function My_Test (N : Node_Id) return Boolean; + + type Node_Kind is (N_Unused_At_Start, N_Unused_At_End); + + type Entity_Kind is ( + + E_Void, + E_Component, + E_Constant, + E_Discriminant, + E_Loop_Parameter, + E_Variable, + E_Out_Parameter, + E_In_Out_Parameter, + E_In_Parameter, + E_Generic_In_Out_Parameter, + E_Generic_In_Parameter, + E_Named_Integer, + E_Named_Real, + E_Enumeration_Type, + E_Enumeration_Subtype, + E_Signed_Integer_Type, + E_Signed_Integer_Subtype, + E_Modular_Integer_Type, + E_Modular_Integer_Subtype, + E_Ordinary_Fixed_Point_Type, + E_Ordinary_Fixed_Point_Subtype, + E_Decimal_Fixed_Point_Type, + E_Decimal_Fixed_Point_Subtype, + E_Floating_Point_Type, + E_Floating_Point_Subtype, + E_Access_Type, + E_Access_Subtype, + E_Access_Attribute_Type, + E_Allocator_Type, + E_General_Access_Type, + E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Type, + E_Array_Type, + E_Array_Subtype, + E_String_Literal_Subtype, + E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Record_Type, + E_Record_Subtype, + E_Record_Type_With_Private, + E_Record_Subtype_With_Private, + E_Private_Type, + E_Private_Subtype, + E_Limited_Private_Type, + E_Limited_Private_Subtype, + E_Incomplete_Type, + E_Incomplete_Subtype, + E_Task_Type, + E_Task_Subtype, + E_Protected_Type, + E_Protected_Subtype, + E_Exception_Type, + E_Subprogram_Type, + E_Enumeration_Literal, + E_Function, + E_Operator, + E_Procedure, + E_Abstract_State, + E_Entry, + E_Entry_Family, + E_Block, + E_Entry_Index_Parameter, + E_Exception, + E_Generic_Function, + E_Generic_Procedure, + E_Generic_Package, + E_Label, + E_Loop, + E_Return_Statement, + E_Package, + E_Package_Body, + E_Protected_Object, + E_Protected_Body, + E_Task_Body, + E_Subprogram_Body + ); + + subtype Access_Kind is Entity_Kind range + E_Access_Type .. + E_Anonymous_Access_Type; + + subtype Array_Kind is Entity_Kind range + E_Array_Type .. + E_String_Literal_Subtype; + + subtype Object_Kind is Entity_Kind range + E_Component .. + E_Generic_In_Parameter; + + subtype Record_Kind is Entity_Kind range + E_Class_Wide_Type .. + E_Record_Subtype_With_Private; + + subtype Scalar_Kind is Entity_Kind range + E_Enumeration_Type .. + E_Floating_Point_Subtype; + + subtype Type_Kind is Entity_Kind range + E_Enumeration_Type .. + E_Subprogram_Type; + + type Node_Record (Is_Extension : Boolean := False) is record + Flag16 : Boolean; + Nkind : Node_Kind; + end record; + + function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind); + + type Arr is array (Node_Id) of Node_Record; + + Nodes : Arr; + +end Debug10_Pkg; diff --git a/gcc/testsuite/gnat.dg/debug6.adb b/gcc/testsuite/gnat.dg/debug6.adb new file mode 100644 index 0000000000..25fdef206d --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug6.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } +-- { dg-options "-g" } + +with Debug6_Pkg; use Debug6_Pkg; + +procedure Debug6 is + V : Value := (Kind => Undefined); +begin + Process (V); +end Debug6; diff --git a/gcc/testsuite/gnat.dg/debug6_pkg.ads b/gcc/testsuite/gnat.dg/debug6_pkg.ads new file mode 100644 index 0000000000..dfc9744079 --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug6_pkg.ads @@ -0,0 +1,16 @@ +package Debug6_Pkg is + + type Vkind is (Int, Undefined); + for Vkind use (Int => -2 ** 31, Undefined => 0); + + type Value (Kind : Vkind) is record + case Kind is + when Undefined => null; + when Int => Value : Integer; + when others => null; + end case; + end record; + + procedure Process (V : Value); + +end Debug6_Pkg; diff --git a/gcc/testsuite/gnat.dg/debug7.adb b/gcc/testsuite/gnat.dg/debug7.adb new file mode 100644 index 0000000000..3defc2c5f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug7.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-skip-if "No dwarf-2 support" { hppa*-*-hpux* } "*" "" } +-- { dg-options "-cargs -gdwarf-2 -gstrict-dwarf -dA -margs" } +-- { dg-final { scan-assembler "DW_TAG_imported_decl" } } + +package body Debug7 is + function Next (I : Integer) return Integer is + begin + return I + 1; + end Next; +end Debug7; diff --git a/gcc/testsuite/gnat.dg/debug7.ads b/gcc/testsuite/gnat.dg/debug7.ads new file mode 100644 index 0000000000..047d4a6635 --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug7.ads @@ -0,0 +1,4 @@ +package Debug7 is + function Next (I : Integer) return Integer; + function Renamed_Next (I : Integer) return Integer renames Next; +end Debug7; diff --git a/gcc/testsuite/gnat.dg/debug8.adb b/gcc/testsuite/gnat.dg/debug8.adb new file mode 100644 index 0000000000..882be5558d --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug8.adb @@ -0,0 +1,29 @@ +-- { dg-do compile } +-- { dg-options "-cargs -g -fgnat-encodings=minimal -dA -margs" } +-- { dg-final { scan-assembler-not "DW_OP_const4u" } } +-- { dg-final { scan-assembler-not "DW_OP_const8u" } } + +-- The DW_AT_byte_size attribute DWARF expression for the +-- DW_TAG_structure_type DIE that describes Rec_Type contains the -4u literal. +-- Check that it is not created using an inefficient encoding (DW_OP_const1s +-- is expected). + +procedure Debug8 is + + type Rec_Type (I : Integer) is record + B : Boolean; + case I is + when 0 => + null; + when 1 .. 10 => + C : Character; + when others => + N : Natural; + end case; + end record; + + R : access Rec_Type := null; + +begin + null; +end Debug8; diff --git a/gcc/testsuite/gnat.dg/debug9.adb b/gcc/testsuite/gnat.dg/debug9.adb new file mode 100644 index 0000000000..eaf370058a --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug9.adb @@ -0,0 +1,54 @@ +-- The aim of this test is to check that Ada types appear in the proper +-- context in the debug info. +-- +-- Checking this directly would be really tedious just scanning for assembly +-- lines, so instead we rely on DWARFv4's .debug_types sections, which must be +-- created only for global-scope types. Checking the number of .debug_types is +-- some hackish way to check that types are output in the proper context (i.e. +-- at global or local scope). +-- +-- { dg-skip-if "No dwarf-4 support" { hppa*-*-hpux* } "*" "" } +-- { dg-options "-cargs -gdwarf-4 -fdebug-types-section -dA -margs" } +-- { dg-final { scan-assembler-times "\\(DIE \\(0x\[a-f0-9\]*\\) DW_TAG_type_unit\\)" 0 } } + +procedure Debug9 is + type Array_Type is array (Natural range <>) of Integer; + type Record_Type (L1, L2 : Natural) is record + I1 : Integer; + A1 : Array_Type (1 .. L1); + I2 : Integer; + A2 : Array_Type (1 .. L2); + I3 : Integer; + end record; + + function Get (L1, L2 : Natural) return Record_Type is + Result : Record_Type (L1, L2); + begin + Result.I1 := 1; + for I in Result.A1'Range loop + Result.A1 (I) := I; + end loop; + Result.I2 := 2; + for I in Result.A2'Range loop + Result.A2 (I) := I; + end loop; + Result.I3 := 3; + return Result; + end Get; + + R1 : Record_Type := Get (0, 0); + R2 : Record_Type := Get (1, 0); + R3 : Record_Type := Get (0, 1); + R4 : Record_Type := Get (2, 2); + + procedure Process (R : Record_Type) is + begin + null; + end Process; + +begin + Process (R1); + Process (R2); + Process (R3); + Process (R4); +end Debug9; diff --git a/gcc/testsuite/gnat.dg/dg.exp b/gcc/testsuite/gnat.dg/dg.exp index 10699af560..228c71e85b 100644 --- a/gcc/testsuite/gnat.dg/dg.exp +++ b/gcc/testsuite/gnat.dg/dg.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2006-2017 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/gcc/testsuite/gnat.dg/discr47.adb b/gcc/testsuite/gnat.dg/discr47.adb new file mode 100644 index 0000000000..0aaa655ca7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr47.adb @@ -0,0 +1,19 @@ +-- { dg-do run } +-- { dg-options "-O -gnatws" } + +procedure Discr47 is + + type Rec (D : Boolean := False) is record + case D is + when True => null; + when False => C : Character; + end case; + end record; + + R : Rec; + +begin + if R'Size /= 16 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/inline13.adb b/gcc/testsuite/gnat.dg/inline13.adb new file mode 100644 index 0000000000..4be6514aab --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline13.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatn" } + +package body Inline13 is + + function F (L : Arr) return String is + Local : Arr (1 .. L'Length); + Ret : String (1 .. L'Length); + Pos : Natural := 1; + begin + Local (1 .. L'Length) := L; + for I in 1 .. Integer (L'Length) loop + Ret (Pos .. Pos + 8) := " " & Inline13_Pkg.Padded (Local (I)); + Pos := Pos + 9; + end loop; + return Ret; + end; + +end Inline13; diff --git a/gcc/testsuite/gnat.dg/inline13.ads b/gcc/testsuite/gnat.dg/inline13.ads new file mode 100644 index 0000000000..7e8f8d62be --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline13.ads @@ -0,0 +1,9 @@ +with Inline13_Pkg; + +package Inline13 is + + type Arr is array (Positive range <>) of Inline13_Pkg.T; + + function F (L : Arr) return String; + +end Inline13; diff --git a/gcc/testsuite/gnat.dg/inline13_pkg.adb b/gcc/testsuite/gnat.dg/inline13_pkg.adb new file mode 100644 index 0000000000..61c0f05090 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline13_pkg.adb @@ -0,0 +1,8 @@ +package body Inline13_Pkg is + + function Padded (Value : T) return Padded_T is + begin + return Padded_T(Value); + end Padded; + +end Inline13_Pkg; diff --git a/gcc/testsuite/gnat.dg/inline13_pkg.ads b/gcc/testsuite/gnat.dg/inline13_pkg.ads new file mode 100644 index 0000000000..814cf80ff2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline13_pkg.ads @@ -0,0 +1,10 @@ +package Inline13_Pkg is + + subtype Padded_T is String (1..8); + + type T is new Padded_T; + + function Padded (Value : T) return Padded_T; + pragma Inline_Always (Padded); + +end Inline13_Pkg; diff --git a/gcc/testsuite/gnat.dg/limited_with4.adb b/gcc/testsuite/gnat.dg/limited_with4.adb new file mode 100644 index 0000000000..0d3f530c4f --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with4.adb @@ -0,0 +1,43 @@ +-- { dg-do compile } + +with Limited_With4_Pkg; + +package body Limited_With4 is + + procedure Proc1 (A : Limited_With4_Pkg.Rec12 ; I : Integer) is + begin + if A.R.I /= I then + raise Program_Error; + end if; + end; + + function Func1 (I : Integer) return Limited_With4_Pkg.Rec12 is + begin + return (I => I, R => (I => I)); + end; + + procedure Proc2 (A : Limited_With4_Pkg.Rec22 ; I : Integer) is + begin + if A.R.I /= I then + raise Program_Error; + end if; + end; + + function Func2 (I : Integer) return Limited_With4_Pkg.Rec22 is + begin + return (I => I, R => (I => I)); + end; + + procedure Proc3 (A : Limited_With4_Pkg.Rec12 ; B : Limited_With4_Pkg.Rec22) is + begin + if A.R.I /= B.R.I then + raise Program_Error; + end if; + end; + + function Func3 (A : Limited_With4_Pkg.Rec12) return Limited_With4_Pkg.Rec22 is + begin + return (I => A.R.I, R => (I => A.R.I)); + end; + +end Limited_With4; diff --git a/gcc/testsuite/gnat.dg/limited_with4.ads b/gcc/testsuite/gnat.dg/limited_with4.ads new file mode 100644 index 0000000000..bcf77e585c --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with4.ads @@ -0,0 +1,29 @@ +limited with Limited_With4_Pkg; + +package Limited_With4 is + + type Ptr1 is access procedure (A : Limited_With4_Pkg.Rec12; I : Integer); + + type Ptr2 is access procedure (A : Limited_With4_Pkg.Rec22; I : Integer); + + type Rec1 is record + I : Integer; + end record; + + procedure Proc1 (A : Limited_With4_Pkg.Rec12 ; I : Integer); + + function Func1 (I : Integer) return Limited_With4_Pkg.Rec12; + + procedure Proc2 (A : Limited_With4_Pkg.Rec22 ; I : Integer); + + function Func2 (I : Integer) return Limited_With4_Pkg.Rec22; + + type Rec2 is record + I : Integer; + end record; + + procedure Proc3 (A : Limited_With4_Pkg.Rec12 ; B : Limited_With4_Pkg.Rec22); + + function Func3 (A : Limited_With4_Pkg.Rec12) return Limited_With4_Pkg.Rec22; + +end Limited_With4; diff --git a/gcc/testsuite/gnat.dg/limited_with4_pkg.ads b/gcc/testsuite/gnat.dg/limited_with4_pkg.ads new file mode 100644 index 0000000000..38fe7aeeb4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with4_pkg.ads @@ -0,0 +1,19 @@ +with Limited_With4; + +package Limited_With4_Pkg is + + P1 : Limited_With4.Ptr1 := Limited_With4.Proc1'Access; + + P2 : Limited_With4.Ptr2 := Limited_With4.Proc2'Access; + + type Rec12 is record + I : Integer; + R : Limited_With4.Rec1; + end record; + + type Rec22 is record + I : Integer; + R : Limited_With4.Rec2; + end record; + +end Limited_With4_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto15.adb b/gcc/testsuite/gnat.dg/lto15.adb index be5b008e8c..3a6599241d 100644 --- a/gcc/testsuite/gnat.dg/lto15.adb +++ b/gcc/testsuite/gnat.dg/lto15.adb @@ -1,6 +1,5 @@ -- { dg-do compile } --- { dg-options "-O -flto -g" } --- { dg-require-effective-target lto } +-- { dg-options "-O -flto -g" { target lto } } package body Lto15 is diff --git a/gcc/testsuite/gnat.dg/lto16.adb b/gcc/testsuite/gnat.dg/lto16.adb index 82d02b4116..271a6c591f 100644 --- a/gcc/testsuite/gnat.dg/lto16.adb +++ b/gcc/testsuite/gnat.dg/lto16.adb @@ -1,6 +1,5 @@ -- { 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; diff --git a/gcc/testsuite/gnat.dg/lto17.adb b/gcc/testsuite/gnat.dg/lto17.adb index af42e8d85d..504fb877a6 100644 --- a/gcc/testsuite/gnat.dg/lto17.adb +++ b/gcc/testsuite/gnat.dg/lto17.adb @@ -1,6 +1,5 @@ -- { dg-do compile } --- { dg-options "-flto" } --- { dg-require-effective-target lto } +-- { dg-options "-flto" { target lto } } package body Lto17 is diff --git a/gcc/testsuite/gnat.dg/lto18.adb b/gcc/testsuite/gnat.dg/lto18.adb new file mode 100644 index 0000000000..ab4085e1ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18.adb @@ -0,0 +1,16 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto18.ads b/gcc/testsuite/gnat.dg/lto18.ads new file mode 100644 index 0000000000..486bc889e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18.ads @@ -0,0 +1,7 @@ +with Lto18_Pkg; use Lto18_Pkg; + +package Lto18 is + + procedure Proc (Driver : Rec); + +end Lto18; diff --git a/gcc/testsuite/gnat.dg/lto18_pkg.ads b/gcc/testsuite/gnat.dg/lto18_pkg.ads new file mode 100644 index 0000000000..004a1fa97b --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18_pkg.ads @@ -0,0 +1,23 @@ +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; diff --git a/gcc/testsuite/gnat.dg/lto19.adb b/gcc/testsuite/gnat.dg/lto19.adb new file mode 100644 index 0000000000..7f083d3576 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19.adb @@ -0,0 +1,11 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg1.adb b/gcc/testsuite/gnat.dg/lto19_pkg1.adb new file mode 100644 index 0000000000..84b020ba6c --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg1.adb @@ -0,0 +1,5 @@ +package body Lto19_Pkg1 is + + procedure Proc (R : Rec) is begin null; end; + +end Lto19_Pkg1; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg1.ads b/gcc/testsuite/gnat.dg/lto19_pkg1.ads new file mode 100644 index 0000000000..523f538d44 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg1.ads @@ -0,0 +1,14 @@ +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; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg2.adb b/gcc/testsuite/gnat.dg/lto19_pkg2.adb new file mode 100644 index 0000000000..70e731a521 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg2.adb @@ -0,0 +1,5 @@ +package body Lto19_Pkg2 is + + function UB return Natural is begin return 8; end; + +end Lto19_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg2.ads b/gcc/testsuite/gnat.dg/lto19_pkg2.ads new file mode 100644 index 0000000000..7ca6136cc9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg2.ads @@ -0,0 +1,5 @@ +package Lto19_Pkg2 is + + function UB return Natural; + +end Lto19_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto20.adb b/gcc/testsuite/gnat.dg/lto20.adb new file mode 100644 index 0000000000..e4095a9760 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20.adb @@ -0,0 +1,10 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto20_pkg.adb b/gcc/testsuite/gnat.dg/lto20_pkg.adb new file mode 100644 index 0000000000..a5e5aa0ad9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20_pkg.adb @@ -0,0 +1,9 @@ +package body Lto20_Pkg is + + type Obj is record + I : Integer; + end record; + + procedure Proc (A : Arr) is begin null; end; + +end Lto20_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto20_pkg.ads b/gcc/testsuite/gnat.dg/lto20_pkg.ads new file mode 100644 index 0000000000..6ece15f596 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20_pkg.ads @@ -0,0 +1,21 @@ +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; diff --git a/gcc/testsuite/gnat.dg/lto21.adb b/gcc/testsuite/gnat.dg/lto21.adb new file mode 100644 index 0000000000..fe6fb2734b --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto21.adb @@ -0,0 +1,10 @@ +-- { dg-do run } +-- { dg-options "-O3 -flto" { target lto } } + +with Lto21_Pkg1; +with Lto21_Pkg2; use Lto21_Pkg2; + +procedure Lto21 is +begin + Proc; +end; diff --git a/gcc/testsuite/gnat.dg/lto21_pkg1.ads b/gcc/testsuite/gnat.dg/lto21_pkg1.ads new file mode 100644 index 0000000000..000a568c6c --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto21_pkg1.ads @@ -0,0 +1,10 @@ +with Ada.Containers.Vectors; +with Lto21_Pkg2; + +package Lto21_Pkg1 is + + pragma Suppress (Tampering_Check); + + package Vect1 is new Ada.Containers.Vectors (Positive, Natural); + +end Lto21_Pkg1; diff --git a/gcc/testsuite/gnat.dg/lto21_pkg2.adb b/gcc/testsuite/gnat.dg/lto21_pkg2.adb new file mode 100644 index 0000000000..5d38102d8f --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto21_pkg2.adb @@ -0,0 +1,30 @@ +with Ada.Containers; use Ada.Containers; +with Ada.Containers.Hashed_Maps; +with Ada.Containers.Vectors; + +package body Lto21_Pkg2 is + + pragma Suppress (Tampering_Check); + + procedure Proc is + + function Hash (Syd : Natural) return Hash_Type is (Hash_Type'Mod (Syd)); + + package Vect2 is new Vectors (Positive, Natural); + + package Maps is + new Hashed_Maps (Natural, Vect2.Vector, Hash, "=", Vect2."="); + + procedure Nested (M : Maps.Map) is + use Maps; + procedure Inner (Position : Cursor) is null; + begin + Iterate (M, Inner'Access); + end; + + M : Maps.Map; + begin + Nested (M); + end; + +end Lto21_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto21_pkg2.ads b/gcc/testsuite/gnat.dg/lto21_pkg2.ads new file mode 100644 index 0000000000..935b3b71e8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto21_pkg2.ads @@ -0,0 +1,5 @@ +package Lto21_Pkg2 is + + procedure Proc; + +end Lto21_Pkg2; diff --git a/gcc/testsuite/gnat.dg/opt53.adb b/gcc/testsuite/gnat.dg/opt53.adb new file mode 100644 index 0000000000..936277db85 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt53.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-O2 -fdump-tree-optimized" } + +function Opt53 (Val, Max : Positive) return Positive is +begin + if Val >= Max then + return Max; + end if; + return Val + 1; +end; + +-- { dg-final { scan-tree-dump-not "gnat_rcheck" "optimized" } } diff --git a/gcc/testsuite/gnat.dg/opt54.adb b/gcc/testsuite/gnat.dg/opt54.adb new file mode 100644 index 0000000000..b4aaa0900e --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt54.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-O2 -fdump-tree-optimized" } + +function Opt54 (Val, Max : Integer) return Integer is +begin + if Val >= Max then + return Max; + end if; + return Val + 1; +end; + +-- { dg-final { scan-tree-dump-not "gnat_rcheck" "optimized" } } diff --git a/gcc/testsuite/gnat.dg/opt55.adb b/gcc/testsuite/gnat.dg/opt55.adb new file mode 100644 index 0000000000..70f486b2ee --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt55.adb @@ -0,0 +1,20 @@ +-- { dg-do compile }
+-- { dg-options "-O" }
+
+package body Opt55 is
+
+ function Cond (B : Boolean; If_True, If_False : Date) return Date is
+ begin
+ if B then
+ return If_True;
+ else
+ return If_False;
+ end if;
+ end;
+
+ function F (C : Rec2; B : Boolean) return Date is
+ begin
+ return Cond (B, C.D1, C.D2);
+ end;
+
+end Opt55;
diff --git a/gcc/testsuite/gnat.dg/opt55.ads b/gcc/testsuite/gnat.dg/opt55.ads new file mode 100644 index 0000000000..fec3c9ae2e --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt55.ads @@ -0,0 +1,22 @@ +package Opt55 is
+
+ type Date is record
+ D : Float;
+ end record;
+
+ type Rec1 (Kind : Boolean := False) is record
+ case Kind is
+ when True => N : Natural;
+ when False => null;
+ end case;
+ end record;
+
+ type Rec2 (D : Positive) is record
+ R : Rec1;
+ D1 : Date;
+ D2 : Date;
+ end record;
+
+ function F (C : Rec2; B : Boolean) return Date;
+
+end Opt55;
diff --git a/gcc/testsuite/gnat.dg/opt57.adb b/gcc/testsuite/gnat.dg/opt57.adb new file mode 100644 index 0000000000..f532f09df2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt57.adb @@ -0,0 +1,89 @@ +package body Opt57 is + + type Phase_Enum is (None_Phase, FE_Init_Phase, FE_Phase); + + type Message_State is (No_Messages, Some_Messages); + + type Module_List_Array is array (Phase_Enum, Message_State) of List; + + type Private_Module_Factory is limited record + Module_Lists : Module_List_Array; + end record; + + type Element_Array is array (Positive range <>) of Module_Factory_Ptr; + + type Hash_Table is array (Positive range <>) of aliased Module_Factory_Ptr; + + type Heap_Data_Rec (Table_Last : Positive) is limited record + Number_Of_Elements : Positive; + Table : Hash_Table (1 .. Table_Last); + end record; + + type Heap_Data_Ptr is access Heap_Data_Rec; + + type Table is limited record + Data : Heap_Data_Ptr; + end record; + + function All_Elements (M : Table) return Element_Array is + Result : Element_Array (1 .. Natural (M.Data.Number_Of_Elements)); + Last : Natural := 0; + begin + for H in M.Data.Table'Range loop + Last := Last + 1; + Result (Last) := M.Data.Table(H); + end loop; + return Result; + end; + + The_Factories : Table; + + subtype Language_Array is Element_Array; + type Language_Array_Ptr is access Language_Array; + All_Languages : Language_Array_Ptr := null; + + procedure Init is + begin + if All_Languages = null then + All_Languages := new Language_Array'(All_Elements (The_Factories)); + end if; + end; + + function Is_Empty (L : List) return Boolean is + begin + return Link_Constant (L.Next) = L'Unchecked_Access; + end; + + function First (L : List) return Linkable_Ptr is + begin + return Links_Type (L.Next.all).Container.all'Access; + end; + + procedure Update is + Check_New_Dependences : Boolean := False; + begin + loop + for Lang_Index in All_Languages'Range loop + for Has_Messages in Message_State loop + declare + L : List renames + All_Languages (Lang_Index).Priv.Module_Lists + (FE_Init_Phase, Has_Messages); + begin + while not Is_Empty (L) loop + declare + Module_In_Init_State : constant Module_Ptr := + Module_Ptr (First (L)); + Pin_Dependence : Pinned (Module_In_Init_State); + begin + Check_New_Dependences := True; + end; + end loop; + end; + end loop; + end loop; + exit when not Check_New_Dependences; + end loop; + end; + +end Opt57; diff --git a/gcc/testsuite/gnat.dg/opt57.ads b/gcc/testsuite/gnat.dg/opt57.ads new file mode 100644 index 0000000000..1bee7992b1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt57.ads @@ -0,0 +1,50 @@ +-- { dg-do compile } +-- { dg-options "-O3" } + +with Ada.Finalization; use Ada.Finalization; +with Opt57_Pkg; use Opt57_Pkg; + +package Opt57 is + + procedure Update; + + procedure Init; + + type Module_Factory is abstract new Limited_Controlled with private; + + type Root_Module_Rec (Language : access Module_Factory'Class) + is abstract new GC_Pool with null record; + + type List is tagged limited private; + type Linkable is abstract new Root_Module_Rec with private; + type Linkable_Ptr is access all Linkable'Class; + +private + + type Link is access all List'Class; + type Link_Constant is access constant List'Class; + type List is tagged limited record + Next : Link; + end record; + + type Links_Type (Container : access Linkable) is new List with null record; + + type Linkable is abstract new Root_Module_Rec with record + On_List : Link_Constant; + Links : aliased Links_Type (Linkable'Access); + end record; + + type Module_Rec (Language : access Module_Factory'Class) + is abstract new Linkable (Language) with null record; + type Module_Ptr is access all Module_Rec'Class; + + type Private_Module_Factory; + type Private_Module_Factory_Ptr is access Private_Module_Factory; + + type Module_Factory is abstract new Limited_Controlled with record + Priv : Private_Module_Factory_Ptr; + end record; + + type Module_Factory_Ptr is access all Module_Factory'Class; + +end Opt57; diff --git a/gcc/testsuite/gnat.dg/opt57_pkg.ads b/gcc/testsuite/gnat.dg/opt57_pkg.ads new file mode 100644 index 0000000000..9d2a9b6c07 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt57_pkg.ads @@ -0,0 +1,13 @@ +with System.Storage_Pools; use System.Storage_Pools; + +with Ada.Finalization; use Ada.Finalization; + +package Opt57_Pkg is + + type GC_Pool is abstract new Root_Storage_Pool with null record; + + type Pinned (Pool : access GC_Pool'Class) is new Controlled with null record; + + procedure Finalize (X : in out Pinned); + +end Opt57_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt58.adb b/gcc/testsuite/gnat.dg/opt58.adb new file mode 100644 index 0000000000..ac39cc0605 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt58.adb @@ -0,0 +1,19 @@ +-- { dg-do compile }
+-- { dg-options "-O" }
+
+with Unchecked_Conversion;
+with System; use System;
+with Opt58_Pkg; use Opt58_Pkg;
+
+procedure Opt58 is
+
+ function Convert is new Unchecked_Conversion (Integer, Rec);
+
+ Dword : Integer := 0;
+ I : Small_Int := F1 (Convert (Dword));
+
+begin
+ if F2 (Null_Address, I = 0) then
+ null;
+ end if;
+end Opt58;
diff --git a/gcc/testsuite/gnat.dg/opt58_pkg.ads b/gcc/testsuite/gnat.dg/opt58_pkg.ads new file mode 100644 index 0000000000..9cb7f3a254 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt58_pkg.ads @@ -0,0 +1,19 @@ +with System; use System;
+
+package Opt58_Pkg is
+
+ pragma Pure (Opt58_Pkg);
+
+ type Small_Int is range 0 .. 255;
+
+ type Rec is record
+ D1, D2, D3, D4 : Small_Int;
+ end record;
+ pragma Pack (Rec);
+ for Rec'Size use 32;
+
+ function F1 (R : Rec) return Small_Int;
+
+ function F2 (A : Address; B : Boolean) return Boolean;
+
+end Opt58_Pkg;
diff --git a/gcc/testsuite/gnat.dg/opt59.adb b/gcc/testsuite/gnat.dg/opt59.adb new file mode 100644 index 0000000000..29665f4ac6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt59.adb @@ -0,0 +1,49 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Opt59_Pkg; use Opt59_Pkg; + +procedure Opt59 is + + type Enum is (Zero, One, Two); + + function Has_True (V : Boolean_Vector) return Boolean is + begin + for I in V'Range loop + if V (I) then + return True; + end if; + end loop; + return False; + end; + + Data1 : constant Boolean_Vector := Get_BV1; + Data2 : constant Boolean_Vector := Get_BV2; + Result : Boolean_Vector; + + function F return Enum is + Res : Enum := Zero; + Set1 : constant Boolean := Has_True (Data1); + Set2 : constant Boolean := Has_True (Data2); + begin + if Set1 then + Res := Two; + elsif Set2 then + Res := One; + end if; + return Res; + end; + + Val : constant Enum := F; + +begin + + for I in Result'Range loop + Result (I) := Data1 (I) or Data2 (I); + end loop; + + if Val /= Zero then + Test (Val = Two); + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/opt59_pkg.adb b/gcc/testsuite/gnat.dg/opt59_pkg.adb new file mode 100644 index 0000000000..16a183b47e --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt59_pkg.adb @@ -0,0 +1,20 @@ +package body Opt59_Pkg is + + function Get_BV1 return Boolean_Vector is + begin + return (others => True); + end; + + function Get_BV2 return Boolean_Vector is + begin + return (others => False); + end; + + procedure Test (B : Boolean) is + begin + if not B then + raise Program_Error; + end if; + end; + +end Opt59_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt59_pkg.ads b/gcc/testsuite/gnat.dg/opt59_pkg.ads new file mode 100644 index 0000000000..f5628be986 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt59_pkg.ads @@ -0,0 +1,11 @@ +package Opt59_Pkg is + + type Boolean_Vector is array (1 .. 8) of Boolean; + + function Get_BV1 return Boolean_Vector; + + function Get_BV2 return Boolean_Vector; + + procedure Test (B : Boolean); + +end Opt59_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt60.adb b/gcc/testsuite/gnat.dg/opt60.adb new file mode 100644 index 0000000000..9154fb46fa --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt60.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -O2 -fdump-tree-optimized" } + +with System; use System; +with System.CRTL; use System.CRTL; + +function Opt60 (Size : size_t) return System.Address is + Result : System.Address; +begin + Result := malloc (Size); + if Result = System.Null_Address then + raise Program_Error; + end if; + return Result; +end; + +-- { dg-final { scan-tree-dump "== 0B" "optimized" } } diff --git a/gcc/testsuite/gnat.dg/opt61.adb b/gcc/testsuite/gnat.dg/opt61.adb new file mode 100644 index 0000000000..09d5cdc385 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt61.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Interfaces; +with Opt61_Pkg; use Opt61_Pkg; + +procedure Opt61 is + + use type Interfaces.Integer_64; + + X : constant Int64 := 3125; + Y : constant Int64 := 5; + Z : constant Int64 := 10; + Q, R: Int64; + +begin + Double_Divide (X, Y, Z, Q, R, False); + if R /= 25 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/opt61_pkg.adb b/gcc/testsuite/gnat.dg/opt61_pkg.adb new file mode 100644 index 0000000000..c35f703ffd --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt61_pkg.adb @@ -0,0 +1,132 @@ +with Interfaces; use Interfaces; + +with Ada.Unchecked_Conversion; + +package body Opt61_Pkg is + + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + subtype Uns64 is Unsigned_64; + + function To_Int is new Ada.Unchecked_Conversion (Uns64, Int64); + + subtype Uns32 is Unsigned_32; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B)); + -- Length doubling additions + + function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B)); + -- Length doubling multiplication + + function "&" (Hi, Lo : Uns32) return Uns64 is + (Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo)); + -- Concatenate hi, lo values to form 64-bit result + + function "abs" (X : Int64) return Uns64 is + (if X = Int64'First then 2**63 else Uns64 (Int64'(abs X))); + -- Convert absolute value of X to unsigned. Note that we can't just use + -- the expression of the Else, because it overflows for X = Int64'First. + + function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#)); + -- Low order half of 64-bit value + + function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); + -- High order half of 64-bit value + + ------------------- + -- Double_Divide -- + ------------------- + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) + is + Xu : constant Uns64 := abs X; + Yu : constant Uns64 := abs Y; + + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : constant Uns64 := abs Z; + Zhi : constant Uns32 := Hi (Zu); + Zlo : constant Uns32 := Lo (Zu); + + T1, T2 : Uns64; + Du, Qu, Ru : Uns64; + Den_Pos : Boolean; + + begin + if Yu = 0 or else Zu = 0 then + raise Constraint_Error; + end if; + + -- Compute Y * Z. Note that if the result overflows 64 bits unsigned, + -- then the rounded result is clearly zero (since the dividend is at + -- most 2**63 - 1, the extra bit of precision is nice here). + + if Yhi /= 0 then + if Zhi /= 0 then + Q := 0; + R := X; + return; + else + T2 := Yhi * Zlo; + end if; + + else + T2 := (if Zhi /= 0 then Ylo * Zhi else 0); + end if; + + T1 := Ylo * Zlo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Q := 0; + R := X; + return; + end if; + + Du := Lo (T2) & Lo (T1); + + -- Set final signs (RM 4.5.5(27-30)) + + Den_Pos := (Y < 0) = (Z < 0); + + -- Check overflow case of largest negative number divided by 1 + + if X = Int64'First and then Du = 1 and then not Den_Pos then + raise Constraint_Error; + end if; + + -- Perform the actual division + + Qu := Xu / Du; + Ru := Xu rem Du; + + -- Deal with rounding case + + if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then + Qu := Qu + Uns64'(1); + end if; + + -- Case of dividend (X) sign positive + + if X >= 0 then + R := To_Int (Ru); + Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); + + -- Case of dividend (X) sign negative + + else + R := -To_Int (Ru); + Q := (if Den_Pos then -To_Int (Qu) else To_Int (Qu)); + end if; + end Double_Divide; + +end Opt61_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt61_pkg.ads b/gcc/testsuite/gnat.dg/opt61_pkg.ads new file mode 100644 index 0000000000..ffc5634fad --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt61_pkg.ads @@ -0,0 +1,12 @@ +with Interfaces; + +package Opt61_Pkg is + + subtype Int64 is Interfaces.Integer_64; + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean); + +end Opt61_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt62.adb b/gcc/testsuite/gnat.dg/opt62.adb new file mode 100644 index 0000000000..eb7a806d22 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt62.adb @@ -0,0 +1,15 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Opt62_Pkg; use Opt62_Pkg; + +procedure Opt62 is + + String5 : String(1..5) := "12345"; + D: Der := (Unconstrained_Der with D2 => 5, S2 => String5); + +begin + if D.Str1 /= "abcde" then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/opt62_pkg.ads b/gcc/testsuite/gnat.dg/opt62_pkg.ads new file mode 100644 index 0000000000..348ee0b3c4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt62_pkg.ads @@ -0,0 +1,19 @@ +package Opt62_Pkg is + + Default_String : constant String := "This is a default string"; + + subtype Length is Natural range 0..255; + + type Root (D1 : Length) is tagged record + S1 : String(1..D1) := Default_String(1..D1); + end record; + + type Unconstrained_Der is new Root with record + Str1 : String(1..5) := "abcde"; + end record; + + type Der (D2 : Length) is new Unconstrained_Der (D1 => 10) with record + S2 : String(1..D2); + end record; + +end Opt62_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt63.adb b/gcc/testsuite/gnat.dg/opt63.adb new file mode 100644 index 0000000000..6471be40bb --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt63.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatws" } + +procedure Opt63 is + + type T_MOD is mod 2**32; + subtype T_INDEX is T_MOD range 3_000_000_000 .. 4_000_000_000; + type T_ARRAY is array(T_INDEX range <>) of INTEGER; + + function Build_Crash(First : T_INDEX; Length : NATURAL) return T_ARRAY is + R : T_ARRAY(First .. T_Index'Val (T_Index'Pos (First) + Length)) + := (others => -1); -- Crash here + begin + return R; + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/opt64.adb b/gcc/testsuite/gnat.dg/opt64.adb new file mode 100644 index 0000000000..6d287d301a --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt64.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +-- The issue which prompted the test is a compilation failure. Might +-- as well verify that the generated code performs as expected. + +with opt64_pkg; use opt64_pkg; + +procedure opt64 is + procedure assert (T : boolean) is + begin + if not T then + raise program_error; + end if; + end; +begin + Encode (1); + assert (last_hash = "1"); + Encode (2); + assert (last_hash = "2"); + Encode (3); + assert (last_hash = "3"); + Encode (6); + assert (last_hash = "?"); +end; diff --git a/gcc/testsuite/gnat.dg/opt64_pkg.adb b/gcc/testsuite/gnat.dg/opt64_pkg.adb new file mode 100644 index 0000000000..5235e73b88 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt64_pkg.adb @@ -0,0 +1,14 @@ +package body Opt64_PKG is + + procedure Encode (X : Integer) is + result : Hash; + begin + case X is + when 1 => result := "1"; + when 2 => result := "2"; + when 3 => result := "3"; + when others => Result := "?"; + end case; + Last_Hash := Result; + end; +end; diff --git a/gcc/testsuite/gnat.dg/opt64_pkg.ads b/gcc/testsuite/gnat.dg/opt64_pkg.ads new file mode 100644 index 0000000000..e4b09fcc02 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt64_pkg.ads @@ -0,0 +1,6 @@ +package Opt64_PKG is + type Hash is new string (1 .. 1); + Last_Hash : Hash; + + procedure Encode (X : Integer); +end; diff --git a/gcc/testsuite/gnat.dg/renaming11.adb b/gcc/testsuite/gnat.dg/renaming11.adb new file mode 100644 index 0000000000..c9241c28d8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming11.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +package body Renaming11 is + + function F (Arg: Ptr3) return Integer is + V : Ptr1 renames Arg.all.all; + I : Integer renames V.A(1); + begin + return I; + end; + +end Renaming11; diff --git a/gcc/testsuite/gnat.dg/renaming11.ads b/gcc/testsuite/gnat.dg/renaming11.ads new file mode 100644 index 0000000000..d3dda72ede --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming11.ads @@ -0,0 +1,19 @@ +package Renaming11 is + + subtype Index_Type is Integer range 1..10; + + type Arr is array (Index_Type range <>) of Integer; + + type Rec (Min : Index_Type; Max : Index_Type) is record + A : Arr (Min .. Max); + end record; + + type Ptr1 is access Rec; + + type Ptr2 is access Ptr1; + + type Ptr3 is access Ptr2; + + function F (Arg : Ptr3) return Integer; + +end Renaming11; diff --git a/gcc/testsuite/gnat.dg/self1.adb b/gcc/testsuite/gnat.dg/self1.adb deleted file mode 100644 index dc6f485b8f..0000000000 --- a/gcc/testsuite/gnat.dg/self1.adb +++ /dev/null @@ -1,21 +0,0 @@ --- { dg-do compile } - -procedure Self1 is - type Event; - - type Link (E : access Event) is limited record - Val : Integer; - end record; - - type Ptr is access all Event; - - type Event is tagged limited record - Inner : Link (Event'access); - Size : Integer; - end record; - - Obj2 : Ptr := new Event'(Inner => (Event'access, 15), - Size => Link'size); -begin - null; -end; diff --git a/gcc/testsuite/gnat.dg/specs/specs.exp b/gcc/testsuite/gnat.dg/specs/specs.exp index 81d7c3bc6e..bd3ecbdaed 100644 --- a/gcc/testsuite/gnat.dg/specs/specs.exp +++ b/gcc/testsuite/gnat.dg/specs/specs.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2006-2017 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/gcc/testsuite/gnat.dg/specs/vfa.ads b/gcc/testsuite/gnat.dg/specs/vfa.ads new file mode 100644 index 0000000000..a63be969d5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/vfa.ads @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-g" } + +package VFA is + + type Rec is record + A : Short_Integer; + B : Short_Integer; + end record; + + type Rec_VFA is new Rec; + pragma Volatile_Full_Access (Rec_VFA); + +end VFA; diff --git a/gcc/testsuite/gnat.dg/sso/sso.exp b/gcc/testsuite/gnat.dg/sso/sso.exp index 6ab2d9e8b4..c3e59304f2 100644 --- a/gcc/testsuite/gnat.dg/sso/sso.exp +++ b/gcc/testsuite/gnat.dg/sso/sso.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2013-2016 Free Software Foundation, Inc. +# Copyright (C) 2013-2017 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/gcc/testsuite/gnat.dg/trampoline3.adb b/gcc/testsuite/gnat.dg/trampoline3.adb new file mode 100644 index 0000000000..2805766245 --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline3.adb @@ -0,0 +1,22 @@ +-- { dg-do compile { target *-*-linux* } } +-- { dg-options "-gnatws" } + +procedure Trampoline3 is + + A : Integer; + + type FuncPtr is access function (I : Integer) return Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + P : FuncPtr := F'Access; + I : Integer; + +begin + I := P(0); +end; + +-- { dg-final { scan-assembler-not "GNU-stack.*x" } } diff --git a/gcc/testsuite/gnat.dg/trampoline4.adb b/gcc/testsuite/gnat.dg/trampoline4.adb new file mode 100644 index 0000000000..c79723974d --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline4.adb @@ -0,0 +1,23 @@ +-- { dg-do compile { target *-*-linux* } } +-- { dg-options "-ftrampolines -gnatws" } +-- { dg-skip-if "standard descriptors" { hppa*-*-* ia64-*-* powerpc64-*-* } } + +procedure Trampoline4 is + + A : Integer; + + type FuncPtr is access function (I : Integer) return Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + P : FuncPtr := F'Access; + I : Integer; + +begin + I := P(0); +end; + +-- { dg-final { scan-assembler "GNU-stack.*x" } } diff --git a/gcc/testsuite/gnat.dg/unchecked_convert10.adb b/gcc/testsuite/gnat.dg/unchecked_convert10.adb new file mode 100644 index 0000000000..13b24c1e6a --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert10.adb @@ -0,0 +1,42 @@ +-- { dg-do run } + +with Unchecked_Conversion; + +procedure Unchecked_Convert10 is + + subtype Unsigned_Type is Integer range 2_034 .. 2_164; + + subtype Signed_Type is Integer range -2048 .. 2047; + + function To_Signed_Type is + new Unchecked_Conversion (Source => Unsigned_Type, Target => Signed_Type); + + function To_Unsigned_Type is + new Unchecked_Conversion (Source => Signed_Type, Target => Unsigned_Type); + + Data : Unsigned_Type; + Temp : Signed_Type; + +begin + + Data := 2100; + Temp := To_Signed_Type (Data); + if Temp /= -1996 then + raise Program_Error; + end if; + Data := To_Unsigned_Type (Temp); + if Data /= 2100 then + raise Program_Error; + end if; + + Data := 2047; + Temp := To_Signed_Type (Data); + if Temp /= 2047 then + raise Program_Error; + end if; + Data := To_Unsigned_Type (Temp); + if Data /= 2047 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert11.adb b/gcc/testsuite/gnat.dg/unchecked_convert11.adb new file mode 100644 index 0000000000..ad98a88142 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert11.adb @@ -0,0 +1,47 @@ +-- { dg-do run } + +with Unchecked_Conversion; + +procedure Unchecked_Convert11 is + + subtype Unsigned_Type is Integer range 2_034 .. 2_164; + + subtype Signed_Type is Integer range -2048 .. 2047; + + type Rec is record + S : Signed_Type; + end record; + pragma Pack (Rec); + + function To_Signed_Type is + new Unchecked_Conversion (Source => Unsigned_Type, Target => Rec); + + function To_Unsigned_Type is + new Unchecked_Conversion (Source => Rec, Target => Unsigned_Type); + + Data : Unsigned_Type; + Temp : Rec; + +begin + + Data := 2100; + Temp := To_Signed_Type (Data); + if Temp.S /= -1996 then + raise Program_Error; + end if; + Data := To_Unsigned_Type (Temp); + if Data /= 2100 then + raise Program_Error; + end if; + + Data := 2047; + Temp := To_Signed_Type (Data); + if Temp.S /= 2047 then + raise Program_Error; + end if; + Data := To_Unsigned_Type (Temp); + if Data /= 2047 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert12.adb b/gcc/testsuite/gnat.dg/unchecked_convert12.adb new file mode 100644 index 0000000000..6a7ad22cd0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert12.adb @@ -0,0 +1,47 @@ +-- { dg-do run } + +with Unchecked_Conversion; + +procedure Unchecked_Convert12 is + + subtype Unsigned_Type is Integer range 2_034 .. 2_164; + + subtype Signed_Type is Integer range -2048 .. 2047; + + type Rec is record + S : Unsigned_Type; + end record; + pragma Pack (Rec); + + function To_Signed_Type is + new Unchecked_Conversion (Source => Rec, Target => Signed_Type); + + function To_Unsigned_Type is + new Unchecked_Conversion (Source => Signed_Type, Target => Rec); + + Data : Signed_Type; + Temp : Rec; + +begin + + Data := -1996; + Temp := To_Unsigned_Type (Data); + if Temp.S /= 2100 then + raise Program_Error; + end if; + Data := To_Signed_Type (Temp); + if Data /= -1996 then + raise Program_Error; + end if; + + Data := 2047; + Temp := To_Unsigned_Type (Data); + if Temp.S /= 2047 then + raise Program_Error; + end if; + Data := To_Signed_Type (Temp); + if Data /= 2047 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/vect1.adb b/gcc/testsuite/gnat.dg/vect1.adb index d1652165d5..12c0c7bf42 100644 --- a/gcc/testsuite/gnat.dg/vect1.adb +++ b/gcc/testsuite/gnat.dg/vect1.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect1 is diff --git a/gcc/testsuite/gnat.dg/vect2.adb b/gcc/testsuite/gnat.dg/vect2.adb index bcf60caab6..66cb4e5a2d 100644 --- a/gcc/testsuite/gnat.dg/vect2.adb +++ b/gcc/testsuite/gnat.dg/vect2.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect2 is diff --git a/gcc/testsuite/gnat.dg/vect3.adb b/gcc/testsuite/gnat.dg/vect3.adb index af74771c9b..b3326905e6 100644 --- a/gcc/testsuite/gnat.dg/vect3.adb +++ b/gcc/testsuite/gnat.dg/vect3.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect3 is diff --git a/gcc/testsuite/gnat.dg/vect4.adb b/gcc/testsuite/gnat.dg/vect4.adb index a8e1fcc630..d1f7ed88e1 100644 --- a/gcc/testsuite/gnat.dg/vect4.adb +++ b/gcc/testsuite/gnat.dg/vect4.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect4 is diff --git a/gcc/testsuite/gnat.dg/vect5.adb b/gcc/testsuite/gnat.dg/vect5.adb index 3235c2dc81..dbeb813827 100644 --- a/gcc/testsuite/gnat.dg/vect5.adb +++ b/gcc/testsuite/gnat.dg/vect5.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect5 is diff --git a/gcc/testsuite/gnat.dg/vect6.adb b/gcc/testsuite/gnat.dg/vect6.adb index 71674d4249..5ab72da9aa 100644 --- a/gcc/testsuite/gnat.dg/vect6.adb +++ b/gcc/testsuite/gnat.dg/vect6.adb @@ -1,5 +1,5 @@ -- { dg-do compile { target i?86-*-* x86_64-*-* } } --- { dg-options "-O3 -msse2 -fdump-tree-vect-details" } +-- { dg-options "-O3 -msse2 -fno-vect-cost-model -fdump-tree-vect-details" } package body Vect6 is |