OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gnat.dg/] [bip_aggregate_bug.adb] - Blame information for rev 696

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 696 jeremybenn
--  { dg-do run }
2
 
3
procedure BIP_Aggregate_Bug is
4
 
5
   package Limited_Types is
6
 
7
      type Lim_Tagged is tagged limited record
8
         Root_Comp : Integer;
9
      end record;
10
 
11
      type Lim_Ext is new Lim_Tagged with record
12
         Ext_Comp : Integer;
13
      end record;
14
 
15
      function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class;
16
 
17
   end Limited_Types;
18
 
19
   package body Limited_Types is
20
 
21
      function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class is
22
      begin
23
         case Choice is
24
            when 111 =>
25
               return Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice);
26
            when 222 =>
27
               return Result : Lim_Tagged'Class
28
                        := Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice);
29
            when others =>
30
               return Lim_Tagged'(Root_Comp => Choice);
31
         end case;
32
      end Func_Lim_Tagged;
33
 
34
   end Limited_Types;
35
 
36
   use Limited_Types;
37
 
38
   LT_Root : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 999);
39
   LT_Ext1 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 111);
40
   LT_Ext2 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 222);
41
 
42
begin
43
   if LT_Root.Root_Comp /= 999
44
     or else Lim_Ext (LT_Ext1).Ext_Comp /= 111
45
     or else Lim_Ext (LT_Ext2).Ext_Comp /= 222
46
   then
47
      raise Program_Error;
48
   end if;
49
end BIP_Aggregate_Bug;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.