+2018-02-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/84277
+ * gnat.dg/array11.adb (Array11): Tweak index and remove warning.
+ * gnat.dg/dispatch1.adb: Rename into...
+ * gnat.dg/disp1.adb: ...this.
+ * gnat.dg/dispatch1_p.ads: Rename into...
+ * gnat.dg/disp1_pkg.ads: ...this.
+ * gnat.dg/disp2.adb: Rename into...
+ * gnat.dg/dispatch2.adb: ...this.
+ * gnat.dg/dispatch2_p.ads: Rename into...
+ * gnat.dg/disp2_pkg.ads: ...this.
+ * gnat.dg/dispatch2_p.adb: Rename into...
+ * gnat.dg/disp2_pkg.adb: this.
+ * gnat.dg/generic_dispatch.adb: Rename into...
+ * gnat.dg/generic_disp.adb: this.
+ * gnat.dg/generic_dispatch_p.ads: Rename into...
+ * gnat.dg/generic_disp_pkg.ads: ...this.
+ * gnat.dg/generic_dispatch_p.adb: Rename into...
+ * gnat.dg/generic_disp_pkg.adb: ...this.
+ * gnat.dg/null_pointer_deref1.adb (Null_Pointer_Deref1): Robustify.
+ * gnat.dg/null_pointer_deref2.adb (Null_Pointer_Deref2): Likewise.
+ * gnat.dg/object_overflow1.adb: Tweak index.
+ * gnat.dg/object_overflow2.adb: Likewise.
+ * gnat.dg/object_overflow3.adb: Likewise.
+ * gnat.dg/object_overflow4.adb: Likewise.
+ * gnat.dg/object_overflow5.adb: Likewise.
+
2018-02-16 Jakub Jelinek <jakub@redhat.com>
PR ipa/84425
-- { dg-do compile }
+with System;
+
procedure Array11 is
type Rec is null record;
- type Ptr is access all Rec;
+ type Index_T is mod System.Memory_Size;
- type Arr1 is array (1..8) of aliased Rec; -- { dg-warning "padded" }
- type Arr2 is array (Long_Integer) of aliased Rec; -- { dg-warning "padded" }
+ type Arr1 is array (1 .. 8) of aliased Rec; -- { dg-warning "padded" }
+ type Arr2 is array (Index_T) of aliased Rec; -- { dg-warning "padded" }
A1 : Arr1;
- A2 : Arr2; -- { dg-warning "Storage_Error" }
+ A2 : Arr2;
begin
null;
--- /dev/null
+-- { dg-do run }
+
+with Disp1_Pkg; use Disp1_Pkg;
+
+procedure Disp1 is
+ O : DT_I1;
+ Ptr : access I1'Class;
+begin
+ Ptr := new I1'Class'(I1'Class (O));
+end;
--- /dev/null
+package Disp1_Pkg is
+
+ type I1 is interface;
+ type DT_I1 is new I1 with null record;
+
+end Disp1_Pkg;
--- /dev/null
+-- { dg-do run }
+
+with Disp2_Pkg; use Disp2_Pkg;
+
+procedure Disp2 is
+ Obj : Object_Ptr := new Object;
+begin
+ if Obj.Get_Ptr /= Obj.Impl_Of then
+ raise Program_Error;
+ end if;
+end;
--- /dev/null
+package body Disp2_Pkg is
+
+ function Impl_Of (Self : access Object) return Object_Ptr is
+ begin
+ return Object_Ptr (Self);
+ end Impl_Of;
+
+end Disp2_Pkg;
--- /dev/null
+package Disp2_Pkg is
+
+ type Object is tagged null record;
+ type Object_Ptr is access all Object'CLASS;
+
+ function Impl_Of (Self : access Object) return Object_Ptr;
+ function Get_Ptr (Self : access Object) return Object_Ptr
+ renames Impl_Of;
+
+end Disp2_Pkg;
+
+++ /dev/null
--- { dg-do run }
-
-with dispatch1_p; use dispatch1_p;
-procedure dispatch1 is
- O : DT_I1;
- Ptr : access I1'Class;
-begin
- Ptr := new I1'Class'(I1'Class (O));
-end;
+++ /dev/null
-package dispatch1_p is
- type I1 is interface;
- type DT_I1 is new I1 with null record;
-end;
+++ /dev/null
--- { dg-do run }
-
-with dispatch2_p; use dispatch2_p;
-procedure dispatch2 is
- Obj : Object_Ptr := new Object;
-begin
- if Obj.Get_Ptr /= Obj.Impl_Of then
- raise Program_Error;
- end if;
-end;
+++ /dev/null
---
-package body dispatch2_p is
- function Impl_Of (Self : access Object) return Object_Ptr is
- begin
- return Object_Ptr (Self);
- end Impl_Of;
-end;
+++ /dev/null
-package dispatch2_p is
- type Object is tagged null record;
- type Object_Ptr is access all Object'CLASS;
---
- function Impl_Of (Self : access Object) return Object_Ptr;
- function Get_Ptr (Self : access Object) return Object_Ptr
- renames Impl_Of;
-end;
--- /dev/null
+-- { dg-do run }
+
+with Generic_Disp_Pkg; use Generic_Disp_Pkg;
+
+procedure Generic_Disp is
+ I : aliased Integer := 0;
+ D : Iface'Class := Dispatching_Constructor (DT'Tag, I'access);
+begin
+ null;
+end Generic_Disp;
--- /dev/null
+package body Generic_Disp_Pkg is
+
+ function Constructor (I : not null access Integer) return DT is
+ R : DT;
+ begin
+ return R;
+ end Constructor;
+
+end Generic_Disp_Pkg;
--- /dev/null
+with Ada.Tags.Generic_Dispatching_Constructor;
+
+package Generic_Disp_Pkg is
+ type Iface is interface;
+ function Constructor (I : not null access Integer) return Iface is abstract;
+ function Dispatching_Constructor
+ is new Ada.Tags.Generic_Dispatching_Constructor
+ (T => Iface,
+ Parameters => Integer,
+ Constructor => Constructor);
+ type DT is new Iface with null record;
+ overriding
+ function Constructor (I : not null access Integer) return DT;
+end Generic_Disp_Pkg;
+++ /dev/null
--- { dg-do run }
-
-with generic_dispatch_p; use generic_dispatch_p;
-procedure generic_dispatch is
- I : aliased Integer := 0;
- D : Iface'Class := Dispatching_Constructor (DT'Tag, I'access);
-begin
- null;
-end generic_dispatch;
+++ /dev/null
-package body generic_dispatch_p is
- function Constructor (I : not null access Integer) return DT is
- R : DT;
- begin
- return R;
- end Constructor;
-end;
+++ /dev/null
-with Ada.Tags.Generic_Dispatching_Constructor;
-package generic_dispatch_p is
- type Iface is interface;
- function Constructor (I : not null access Integer) return Iface is abstract;
- function Dispatching_Constructor
- is new Ada.Tags.Generic_Dispatching_Constructor
- (T => Iface,
- Parameters => Integer,
- Constructor => Constructor);
- type DT is new Iface with null record;
- overriding
- function Constructor (I : not null access Integer) return DT;
-end;
begin
Data.all := 1;
exception
- when Constraint_Error | Storage_Error => null;
+ when others => null;
end;
begin
Data.all := 1;
exception
- when Constraint_Error | Storage_Error => null;
+ when others => null;
end T;
begin
-- { dg-do compile }
+with Interfaces.C; use Interfaces.C;
+
procedure Object_Overflow1 is
procedure Proc (x : Boolean) is begin null; end;
- type Arr is array(Long_Integer) of Boolean;
+ type Arr is array(ptrdiff_t) of Boolean;
Obj : Arr; -- { dg-warning "Storage_Error" }
begin
-- { dg-do compile }
+with Interfaces.C; use Interfaces.C;
+
procedure Object_Overflow2 is
procedure Proc (x : Boolean) is begin null; end;
- type Arr is array(0 .. Long_Integer'Last) of Boolean;
+ type Arr is array(0 .. ptrdiff_t'Last) of Boolean;
Obj : Arr; -- { dg-warning "Storage_Error" }
begin
-- { dg-do compile }
+with Interfaces.C; use Interfaces.C;
+
procedure Object_Overflow3 is
procedure Proc (x : Boolean) is begin null; end;
- type Arr is array(0 .. Long_Integer'Last) of Boolean;
+ type Arr is array(0 .. ptrdiff_t'Last) of Boolean;
type Rec is record
A : Arr;
-- { dg-do compile }
+with Interfaces.C; use Interfaces.C;
+
procedure Object_Overflow4 is
procedure Proc (x : Integer) is begin null; end;
- type Index is new Long_Integer range 0 .. Long_Integer'Last;
+ type Index_T is new ptrdiff_t range 0 .. ptrdiff_t'Last;
- type Arr is array(Index range <>) of Integer;
+ type Arr is array(Index_T range <>) of Integer;
- type Rec (Size: Index := 6) is record -- { dg-warning "Storage_Error" }
+ type Rec (Size: Index_T := 6) is record -- { dg-warning "Storage_Error" }
A: Arr (0..Size);
end record;
-- { dg-do compile }
+with Interfaces.C; use Interfaces.C;
+
procedure Object_Overflow5 is
procedure Proc (c : Character) is begin null; end;
- type Index is new Long_Integer range 0 .. Long_Integer'Last;
+ type Index_T is new ptrdiff_t range 0 .. ptrdiff_t'Last;
- type Arr is array(Index range <>) of Character;
+ type Arr is array(Index_T range <>) of Character;
- type Rec (Size: Index := 6) is record -- { dg-warning "Storage_Error" }
+ type Rec (Size: Index_T := 6) is record -- { dg-warning "Storage_Error" }
A: Arr (0..Size);
end record;
projects / gcc.git / commitdiff