--- /dev/null
+
+package body access3 is
+
+ type IT_Access is not null access all IT'Class;
+ for IT_Access'Storage_Size use 0;
+
+ procedure Op
+ (Obj_T2 : in out T2;
+ Obj_IT : not null access IT'Class)
+ is
+ X : constant IT_Access := Obj_IT.all'Unchecked_Access;
+ begin
+ null;
+ end Op;
+
+end access3;
--- /dev/null
+
+package access3 is
+ type IT is limited interface;
+ type T is limited new IT with null record;
+
+ type T2 is tagged limited null record;
+
+ procedure Op
+ (Obj_T2 : in out T2;
+ Obj_IT : not null access IT'Class);
+end access3;
--- /dev/null
+-- { dg-do run }
+
+with access3; use access3;
+procedure access4 is
+ Obj_IT : aliased T;
+ Obj_T2 : T2;
+begin
+ Obj_T2.Op (Obj_IT'Access);
+end;
--- /dev/null
+-- { dg-do compile }
+
+procedure Bad_Array is
+ A1 : array(Character range <> ) of Character := ( 'a', 'b', 'c' );
+begin
+ null;
+end Bad_Array;
--- /dev/null
+-- { dg-do run }
+-- { dg-options "-gnatws" }
+
+procedure discr4 is
+ package Pkg is
+ type Rec_Comp (D : access Integer) is record
+ Data : Integer;
+ end record;
+--
+ type I is interface;
+ procedure Test (Obj : I) is abstract;
+--
+ Num : aliased Integer := 10;
+--
+ type Root (D : access Integer) is tagged record
+ C1 : Rec_Comp (D); -- test
+ end record;
+--
+ type DT is new Root and I with null record;
+--
+ procedure Dummy (Obj : DT);
+ procedure Test (Obj : DT);
+ end;
+--
+ package body Pkg is
+ procedure Dummy (Obj : DT) is
+ begin
+ raise Program_Error;
+ end;
+--
+ procedure Test (Obj : DT) is
+ begin
+ null;
+ end;
+ end;
+--
+ use Pkg;
+--
+ procedure CW_Test (Obj : I'Class) is
+ begin
+ Obj.Test;
+ end;
+--
+ Obj : DT (Num'Access);
+begin
+ CW_Test (Obj);
+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 }
+-- { dg-options "-gnatws" }
+
+with Text_IO;
+procedure renaming2 is
+ type RealNodeData;
+ type RefRealNodeData is access RealNodeData;
+
+ type ExpressionEntry;
+ type RefExpression is access ExpressionEntry;
+
+ type RefDefUseEntry is access Natural;
+
+ type ExpressionEntry is
+ record
+ Number : RefDefUseEntry;
+ Id : Integer;
+ end record;
+
+ type RealNodeData is
+ record
+ Node : RefExpression;
+ Id : Integer;
+ end record;
+
+ for ExpressionEntry use
+ record
+ Number at 0 range 0 .. 63;
+ Id at 8 range 0 .. 31;
+ end record ;
+
+ for RealNodeData use
+ record
+ Node at 0 range 0 .. 63;
+ Id at 8 range 0 .. 31;
+ end record ;
+
+ U_Node : RefDefUseEntry := new Natural'(1);
+ E_Node : RefExpression := new ExpressionEntry'(Number => U_Node,
+ Id => 2);
+ R_Node : RefRealNodeData := new RealNodeData'(Node => E_Node,
+ Id => 3);
+
+ procedure test_routine (NodeRealData : RefRealNodeData)
+ is
+ OldHead : RefDefUseEntry renames NodeRealData.all.Node.all.Number;
+ OldHead1 : constant RefDefUseEntry := OldHead;
+ begin
+ NodeRealData.all.Node := new ExpressionEntry'(Number => null, Id => 4);
+ declare
+ OldHead2 : constant RefDefUseEntry := OldHead;
+ begin
+ if OldHead1 /= OldHead2
+ then
+ Text_IO.Put_Line (" OldHead changed !!!");
+ end if;
+ end;
+ end;
+begin
+ test_routine (R_Node);
+end;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatI" }
+
+package gnati is
+ type j is range 1 .. 50;
+ for j'size use 1;
+ type n is new integer;
+ for n'alignment use -99;
+ type e is (a, b);
+ for e use (1, 1);
+ type r is record x : integer; end record;
+ for r use record x at 0 range 0 .. 0; end record;
+end gnati;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatwu" }
+
+with Ada.Command_Line; use Ada.Command_Line;
+with Text_IO; use Text_IO;
+procedure warn3 is
+ type Weekdays is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
+begin
+ if Argument_Count > 0 then
+ Put_Line
+ (Argument (1) & " is weekday number"
+ & Integer'Image
+ (Weekdays'Pos (Weekdays'Value (Argument (1)))));
+ end if;
+end;
projects / gcc.git / commitdiff