Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cc/cc51001.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- CC51001.A | |
2 -- | |
3 -- Grant of Unlimited Rights | |
4 -- | |
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, | |
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained | |
7 -- unlimited rights in the software and documentation contained herein. | |
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making | |
9 -- this public release, the Government intends to confer upon all | |
10 -- recipients unlimited rights equal to those held by the Government. | |
11 -- These rights include rights to use, duplicate, release or disclose the | |
12 -- released technical data and computer software in whole or in part, in | |
13 -- any manner and for any purpose whatsoever, and to have or permit others | |
14 -- to do so. | |
15 -- | |
16 -- DISCLAIMER | |
17 -- | |
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR | |
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED | |
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE | |
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE | |
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A | |
23 -- PARTICULAR PURPOSE OF SAID MATERIAL. | |
24 --* | |
25 -- | |
26 -- OBJECTIVE: | |
27 -- Check that a formal parameter of a generic package may be a formal | |
28 -- derived type. Check that the formal derived type may have an unknown | |
29 -- discriminant part. Check that the ancestor type in a formal derived | |
30 -- type definition may be a tagged type, and that the actual parameter | |
31 -- may be a descendant of the ancestor type. Check that the formal derived | |
32 -- type belongs to the derivation class rooted at the ancestor type; | |
33 -- specifically, that components of the ancestor type may be referenced | |
34 -- within the generic. Check that if a formal derived subtype is | |
35 -- indefinite then the actual may be either definite or indefinite. | |
36 -- | |
37 -- TEST DESCRIPTION: | |
38 -- Define a class of tagged types with a definite root type. Extend the | |
39 -- root type with a discriminated component. Since discriminants of | |
40 -- tagged types may not have defaults, the type is indefinite. | |
41 -- | |
42 -- Extend the extension with a second discriminated component, but with | |
43 -- a new discriminant part. Declare a generic package with a formal | |
44 -- derived type using the root type of the class as ancestor, and an | |
45 -- unknown discriminant part. Declare an operation in the generic which | |
46 -- accesses the common component of types in the class. | |
47 -- | |
48 -- In the main program, instantiate the generic with each type in the | |
49 -- class and verify that the operation correctly accesses the common | |
50 -- component. | |
51 -- | |
52 -- | |
53 -- CHANGE HISTORY: | |
54 -- 06 Dec 94 SAIC ACVC 2.0 | |
55 -- | |
56 --! | |
57 | |
58 package CC51001_0 is -- Root type for message class. | |
59 | |
60 subtype Msg_String is String (1 .. 20); | |
61 | |
62 type Msg_Type is tagged record -- Root type of | |
63 Text : Msg_String := (others => ' '); -- class (definite). | |
64 end record; | |
65 | |
66 end CC51001_0; | |
67 | |
68 | |
69 -- No body for CC51001_0. | |
70 | |
71 | |
72 --==================================================================-- | |
73 | |
74 | |
75 with CC51001_0; -- Root type for message class. | |
76 package CC51001_1 is -- Extensions to message class. | |
77 | |
78 subtype Source_Length is Natural range 0 .. 10; | |
79 | |
80 type From_Msg_Type (SLen : Source_Length) is -- Direct derivative | |
81 new CC51001_0.Msg_Type with record -- of root type | |
82 From : String (1 .. SLen); -- (indefinite). | |
83 end record; | |
84 | |
85 subtype Dest_Length is Natural range 0 .. 10; | |
86 | |
87 | |
88 | |
89 type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect | |
90 new From_Msg_Type (SLen => 10) with record -- derivative of | |
91 To : String (1 .. DLen); -- root type | |
92 end record; -- (indefinite). | |
93 | |
94 end CC51001_1; | |
95 | |
96 | |
97 -- No body for CC51001_1. | |
98 | |
99 | |
100 --==================================================================-- | |
101 | |
102 | |
103 with CC51001_0; -- Root type for message class. | |
104 generic -- I/O operations for message class. | |
105 type Message_Type (<>) is new CC51001_0.Msg_Type with private; | |
106 package CC51001_2 is | |
107 | |
108 -- This subprogram contains an artificial result for testing purposes: | |
109 -- the function returns the text of the message to the caller as a string. | |
110 | |
111 function Print_Message (M : in Message_Type) return String; | |
112 | |
113 -- ... Other operations. | |
114 | |
115 end CC51001_2; | |
116 | |
117 | |
118 --==================================================================-- | |
119 | |
120 | |
121 package body CC51001_2 is | |
122 | |
123 -- The implementations of the operations below are purely artificial; the | |
124 -- validity of their implementations in the context of the abstraction is | |
125 -- irrelevant to the feature being tested. | |
126 | |
127 function Print_Message (M : in Message_Type) return String is | |
128 begin | |
129 return M.Text; | |
130 end Print_Message; | |
131 | |
132 end CC51001_2; | |
133 | |
134 | |
135 --==================================================================-- | |
136 | |
137 | |
138 with CC51001_0; -- Root type for message class. | |
139 with CC51001_1; -- Extensions to message class. | |
140 with CC51001_2; -- I/O operations for message class. | |
141 | |
142 with Report; | |
143 procedure CC51001 is | |
144 | |
145 -- Instantiate for various types in the class: | |
146 | |
147 package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite. | |
148 package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite. | |
149 package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite. | |
150 | |
151 | |
152 | |
153 Msg : CC51001_0.Msg_Type := (Text => "This is message #001"); | |
154 FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002", | |
155 SLen => 2, | |
156 From => "Me"); | |
157 TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003", | |
158 From => "You ", | |
159 DLen => 4, | |
160 To => "Them"); | |
161 | |
162 Expected_Msg : constant String := "This is message #001"; | |
163 Expected_FMsg : constant String := "This is message #002"; | |
164 Expected_TFMsg : constant String := "This is message #003"; | |
165 | |
166 begin | |
167 Report.Test ("CC51001", "Check that the formal derived type may have " & | |
168 "an unknown discriminant part. Check that the ancestor " & | |
169 "type in a formal derived type definition may be a " & | |
170 "tagged type, and that the actual parameter may be any " & | |
171 "definite or indefinite descendant of the ancestor type"); | |
172 | |
173 if (Msgs.Print_Message (Msg) /= Expected_Msg) then | |
174 Report.Failed ("Wrong result for definite root type"); | |
175 end if; | |
176 | |
177 if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then | |
178 Report.Failed ("Wrong result for direct indefinite derivative"); | |
179 end if; | |
180 | |
181 if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then | |
182 Report.Failed ("Wrong result for Indirect indefinite derivative"); | |
183 end if; | |
184 | |
185 Report.Result; | |
186 end CC51001; |