Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c7/c730a01.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 -- C730A01.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 tagged type declared in a package specification
28 -- may be passed as a generic formal (tagged) private type to a generic
29 -- package declaration. Check that the formal type may be extended with
30 -- a private extension in the generic package.
31 --
32 -- Check that, in the instance, the private extension inherits the
33 -- user-defined primitive subprograms of the tagged actual.
34 --
35 -- TEST DESCRIPTION:
36 -- Declare a tagged type and an associated primitive subprogram in a
37 -- package specification (foundation code). Declare a generic package
38 -- which takes a tagged type as a formal parameter, and then extends
39 -- it with a private extension (foundation code).
40 --
41 -- Instantiate the generic package with the tagged type from the first
42 -- package (the "generic" extension should now have inherited
43 -- the primitive subprogram of the tagged type from the first
44 -- package).
45 --
46 -- In the main program, call the primitive subprogram inherited by the
47 -- "generic" extension, and verify the correctness of the components.
48 --
49 -- TEST FILES:
50 -- The following files comprise this test:
51 --
52 -- F730A000.A
53 -- F730A001.A
54 -- => C730A01.A
55 --
56 --
57 -- CHANGE HISTORY:
58 -- 06 Dec 94 SAIC ACVC 2.0
59 --
60 --!
61
62
63 with F730A001; -- Book definitions.
64 package C730A01_0 is -- Raw data to be used in creating book elements.
65
66
67 Book_Count : constant := 3;
68
69 subtype Number_Of_Books is Integer range 1 .. Book_Count;
70
71 type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
72
73 Title_List : Data_List := (new String'("Wuthering Heights"),
74 new String'("Heart of Darkness"),
75 new String'("Ulysses"));
76
77 Author_List : Data_List := (new String'("Bronte, Emily"),
78 new String'("Conrad, Joseph"),
79 new String'("Joyce, James"));
80
81 end C730A01_0;
82
83
84 --==================================================================--
85
86
87
88
89 --==================================================================--
90
91
92 -- Library-level instantiation. Actual parameter is tagged record.
93
94 with F730A001; -- Book definitions.
95 with F730A000; -- Singly-linked list abstraction.
96 package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type);
97
98
99 --==================================================================--
100
101
102 with Report;
103
104 with F730A001; -- Book definitions.
105 with C730A01_0; -- Raw book data.
106 with C730A01_1; -- Instance.
107
108 use F730A001; -- Primitive operations of Book_Type directly visible.
109 use C730A01_1; -- Operations inherited by Node_Type directly visible.
110
111 procedure C730A01 is
112
113
114 List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
115
116
117 --========================================================--
118
119
120 procedure Create_List (Title, Author : in C730A01_0.Data_List;
121 Head : in out Priv_Node_Ptr) is
122
123 Book : Priv_Node_Type; -- Object of extended type.
124 Book_Ptr : Priv_Node_Ptr;
125
126 begin
127 for I in C730A01_0.Number_Of_Books loop
128 Create_Book (Title (I), Author (I), Book); -- Call inherited
129 -- operation.
130 Book_Ptr := new Priv_Node_Type'(Book);
131 Add (Book_Ptr, Head);
132 end loop;
133 end Create_List;
134
135
136 --========================================================--
137
138
139 function Bad_List_Contents return Boolean is
140 Book1_Ptr : Priv_Node_Ptr;
141 Book2_Ptr : Priv_Node_Ptr;
142 Book3_Ptr : Priv_Node_Ptr;
143 begin
144 Remove (List_Of_Books, Book1_Ptr);
145 Remove (List_Of_Books, Book2_Ptr);
146 Remove (List_Of_Books, Book3_Ptr);
147 return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
148 Book1_Ptr.Author.all /= "Joyce, James" or -- components
149 Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
150 Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in
151 Book3_Ptr.Title.all /= "Wuthering Heights" or -- private
152 Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension.
153
154 end Bad_List_Contents;
155
156
157 --========================================================--
158
159
160 begin -- Main program.
161
162 Report.Test ("C730A01", "Inheritance of primitive operations: private " &
163 "extension of formal tagged private type; actual is " &
164 "an ultimate ancestor type");
165
166 -- Create linked list using inherited operation:
167 Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books);
168
169 -- Verify results:
170 if Bad_List_Contents then
171 Report.Failed ("Wrong values after call to inherited operation");
172 end if;
173
174 Report.Result;
175
176 end C730A01;