| -- C392014.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- The Ada Conformity Assessment Authority (ACAA) holds unlimited |
| -- rights in the software and documentation contained herein. Unlimited |
| -- rights are the same as those granted by the U.S. Government for older |
| -- parts of the Ada Conformity Assessment Test Suite, and are defined |
| -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA |
| -- intends to confer upon all recipients unlimited rights equal to those |
| -- held by the ACAA. These rights include rights to use, duplicate, |
| -- release or disclose the released technical data and computer software |
| -- in whole or in part, in any manner and for any purpose whatsoever, and |
| -- to have or permit others to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that objects designated by X'Access (where X is of a class-wide |
| -- type) and new T'Class'(...) are dynamically tagged and can be used in |
| -- dispatching calls. (Defect Report 8652/0010). |
| -- |
| -- CHANGE HISTORY: |
| -- 18 JAN 2001 PHL Initial version |
| -- 15 MAR 2001 RLB Readied for release. |
| -- 03 JUN 2004 RLB Removed constraint for S0, as the subtype has |
| -- unknown discriminants. |
| |
| --! |
| package C392014_0 is |
| |
| type T (D : Integer) is abstract tagged private; |
| |
| procedure P (X : access T) is abstract; |
| function Create (X : Integer) return T'Class; |
| |
| Result : Natural := 0; |
| |
| private |
| type T (D : Integer) is abstract tagged null record; |
| end C392014_0; |
| |
| with C392014_0; |
| package C392014_1 is |
| type T is new C392014_0.T with private; |
| function Create (X : Integer) return T'Class; |
| private |
| type T is new C392014_0.T with |
| record |
| C1 : Integer; |
| end record; |
| procedure P (X : access T); |
| end C392014_1; |
| |
| package C392014_1.Child is |
| type T is new C392014_1.T with private; |
| procedure P (X : access T); |
| function Create (X : Integer) return T'Class; |
| private |
| type T is new C392014_1.T with |
| record |
| C1C : Integer; |
| end record; |
| end C392014_1.Child; |
| |
| with Report; |
| use Report; |
| with C392014_1.Child; |
| package body C392014_1 is |
| |
| procedure P (X : access T) is |
| begin |
| C392014_0.Result := C392014_0.Result + X.D + X.C1; |
| end P; |
| |
| function Create (X : Integer) return T'Class is |
| begin |
| case X mod Ident_Int (2) is |
| when 0 => |
| return C392014_1.Child.Create (X / Ident_Int (2)); |
| when 1 => |
| declare |
| Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20)); |
| begin |
| Y.C1 := X / Ident_Int (40); |
| return T'Class (Y); |
| end; |
| when others => |
| null; |
| end case; |
| end Create; |
| |
| end C392014_1; |
| |
| with C392014_0; |
| with C392014_1; |
| package C392014_2 is |
| type T is new C392014_0.T with private; |
| function Create (X : Integer) return T'Class; |
| private |
| type T is new C392014_1.T with |
| record |
| C2 : Integer; |
| end record; |
| procedure P (X : access T); |
| end C392014_2; |
| |
| with Report; |
| use Report; |
| with C392014_1.Child; |
| with C392014_2; |
| package body C392014_0 is |
| |
| function Create (X : Integer) return T'Class is |
| begin |
| case X mod 3 is |
| when 0 => |
| return C392014_1.Create (X / Ident_Int (3)); |
| when 1 => |
| return C392014_1.Child.Create (X / Ident_Int (3)); |
| when 2 => |
| return C392014_2.Create (X / Ident_Int (3)); |
| when others => |
| null; |
| end case; |
| end Create; |
| |
| end C392014_0; |
| |
| with Report; |
| use Report; |
| with C392014_0; |
| package body C392014_1.Child is |
| |
| procedure P (X : access T) is |
| begin |
| C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C; |
| end P; |
| |
| function Create (X : Integer) return T'Class is |
| Y : T (D => X mod Ident_Int (20)); |
| begin |
| Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20); |
| Y.C1C := X / Ident_Int (400); |
| return T'Class (Y); |
| end Create; |
| |
| end C392014_1.Child; |
| |
| with Report; |
| use Report; |
| package body C392014_2 is |
| |
| procedure P (X : access T) is |
| begin |
| C392014_0.Result := C392014_0.Result + X.D + X.C2; |
| end P; |
| |
| function Create (X : Integer) return T'Class is |
| Y : T (D => X mod Ident_Int (20)); |
| begin |
| Y.C2 := X / Ident_Int (600); |
| return T'Class (Y); |
| end Create; |
| |
| end C392014_2; |
| |
| with Report; |
| use Report; |
| with C392014_0; |
| with C392014_1.Child; |
| with C392014_2; |
| procedure C392014 is |
| |
| subtype S0 is C392014_0.T'Class; |
| subtype S1 is C392014_1.T'Class; |
| |
| X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218)); |
| X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253)); |
| |
| Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693)); |
| Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622)); |
| |
| procedure TC_Check (Subtest : String; Expected : Integer) is |
| begin |
| if C392014_0.Result = Expected then |
| Comment ("Subtest " & Subtest & " Passed"); |
| else |
| Failed ("Subtest " & Subtest & " Failed"); |
| end if; |
| C392014_0.Result := Ident_Int (0); |
| end TC_Check; |
| |
| begin |
| Test ("C392014", |
| "Check that objects designated by X'Access " & |
| "(where X is of a class-wide type) and New T'Class'(...) " & |
| "are dynamically tagged and can be used in dispatching " & |
| "calls"); |
| |
| C392014_0.P (X0'Access); |
| TC_Check ("X0'Access", Ident_Int (29)); |
| C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850)))); |
| TC_Check ("New C392014_0.T'Class", Ident_Int (27)); |
| C392014_1.P (X1'Access); |
| TC_Check ("X1'Access", Ident_Int (212)); |
| C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031)))); |
| TC_Check ("New C392014_1.T'Class", Ident_Int (65)); |
| C392014_0.P (Y0'Access); |
| TC_Check ("Y0'Access", Ident_Int (18)); |
| C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893)))); |
| TC_Check ("New S0", Ident_Int (20)); |
| C392014_1.P (Y1'Access); |
| TC_Check ("Y1'Access", Ident_Int (18)); |
| C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861)))); |
| TC_Check ("New S1", Ident_Int (56)); |
| |
| Result; |
| end C392014; |