aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sem_ch7.adb
blob: e344a5802db33b00637a99409b2e9afab8b35d0d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              S E M . C H 7                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains the routines to process package specifications and
--  bodies. The most important semantic aspects of package processing are the
--  handling of private and full declarations, and the construction of dispatch
--  tables for tagged types.

with Atree;    use Atree;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Errout;   use Errout;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Dbug; use Exp_Dbug;
with Lib;      use Lib;
with Lib.Xref; use Lib.Xref;
with Namet;    use Namet;
with Nmake;    use Nmake;
with Nlists;   use Nlists;
with Opt;      use Opt;
with Output;   use Output;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Cat;  use Sem_Cat;
with Sem_Ch3;  use Sem_Ch3;
with Sem_Ch6;  use Sem_Ch6;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Snames;   use Snames;
with Stand;    use Stand;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Style;
with Uintp;    use Uintp;

package body Sem_Ch7 is

   -----------------------------------
   -- Handling private declarations --
   -----------------------------------

   --  The principle that each entity has a single defining occurrence clashes
   --  with the presence of two separate definitions for private types: the
   --  first is the private type declaration, and the second is the full type
   --  declaration. It is important that all references to the type point to
   --  the same defining occurrence, namely the first one. To enforce the two
   --  separate views of the entity, the corresponding information is swapped
   --  between the two declarations. Outside of the package, the defining
   --  occurrence only contains the private declaration information, while in
   --  the private part and the body of the package the defining occurrence
   --  contains the full declaration. To simplify the swap, the defining
   --  occurrence that currently holds the private declaration points to the
   --  full declaration. During semantic processing the defining occurrence
   --  also points to a list of private dependents, that is to say access types
   --  or composite types whose designated types or component types are
   --  subtypes or derived types of the private type in question. After the
   --  full declaration has been seen, the private dependents are updated to
   --  indicate that they have full definitions.

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Analyze_Package_Body_Helper (N : Node_Id);
   --  Does all the real work of Analyze_Package_Body

   procedure Check_Anonymous_Access_Types
     (Spec_Id : Entity_Id;
      P_Body  : Node_Id);
   --  If the spec of a package has a limited_with_clause, it may declare
   --  anonymous access types whose designated type is a limited view, such an
   --  anonymous access return type for a function. This access type cannot be
   --  elaborated in the spec itself, but it may need an itype reference if it
   --  is used within a nested scope. In that case the itype reference is
   --  created at the beginning of the corresponding package body and inserted
   --  before other body declarations.

   procedure Install_Package_Entity (Id : Entity_Id);
   --  Supporting procedure for Install_{Visible,Private}_Declarations. Places
   --  one entity on its visibility chain, and recurses on the visible part if
   --  the entity is an inner package.

   function Is_Private_Base_Type (E : Entity_Id) return Boolean;
   --  True for a private type that is not a subtype

   function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
   --  If the private dependent is a private type whose full view is derived
   --  from the parent type, its full properties are revealed only if we are in
   --  the immediate scope of the private dependent. Should this predicate be
   --  tightened further???

   procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
   --  Called upon entering the private part of a public child package and the
   --  body of a nested package, to potentially declare certain inherited
   --  subprograms that were inherited by types in the visible part, but whose
   --  declaration was deferred because the parent operation was private and
   --  not visible at that point. These subprograms are located by traversing
   --  the visible part declarations looking for non-private type extensions
   --  and then examining each of the primitive operations of such types to
   --  find those that were inherited but declared with a special internal
   --  name. Each such operation is now declared as an operation with a normal
   --  name (using the name of the parent operation) and replaces the previous
   --  implicit operation in the primitive operations list of the type. If the
   --  inherited private operation has been overridden, then it's replaced by
   --  the overriding operation.

   --------------------------
   -- Analyze_Package_Body --
   --------------------------

   procedure Analyze_Package_Body (N : Node_Id) is
      Loc : constant Source_Ptr := Sloc (N);

   begin
      if Debug_Flag_C then
         Write_Str ("==> package body ");
         Write_Name (Chars (Defining_Entity (N)));
         Write_Str (" from ");
         Write_Location (Loc);
         Write_Eol;
         Indent;
      end if;

      --  The real work is split out into the helper, so it can do "return;"
      --  without skipping the debug output.

      Analyze_Package_Body_Helper (N);

      if Debug_Flag_C then
         Outdent;
         Write_Str ("<== package body ");
         Write_Name (Chars (Defining_Entity (N)));
         Write_Str (" from ");
         Write_Location (Loc);
         Write_Eol;
      end if;
   end Analyze_Package_Body;

   ---------------------------------
   -- Analyze_Package_Body_Helper --
   ---------------------------------

   procedure Analyze_Package_Body_Helper (N : Node_Id) is
      HSS              : Node_Id;
      Body_Id          : Entity_Id;
      Spec_Id          : Entity_Id;
      Last_Spec_Entity : Entity_Id;
      New_N            : Node_Id;
      Pack_Decl        : Node_Id;

      procedure Install_Composite_Operations (P : Entity_Id);
      --  Composite types declared in the current scope may depend on types
      --  that were private at the point of declaration, and whose full view
      --  is now in scope. Indicate that the corresponding operations on the
      --  composite type are available.

      ----------------------------------
      -- Install_Composite_Operations --
      ----------------------------------

      procedure Install_Composite_Operations (P : Entity_Id) is
         Id : Entity_Id;

      begin
         Id := First_Entity (P);
         while Present (Id) loop
            if Is_Type (Id)
              and then (Is_Limited_Composite (Id)
                         or else Is_Private_Composite (Id))
              and then No (Private_Component (Id))
            then
               Set_Is_Limited_Composite (Id, False);
               Set_Is_Private_Composite (Id, False);
            end if;

            Next_Entity (Id);
         end loop;
      end Install_Composite_Operations;

   --  Start of processing for Analyze_Package_Body_Helper

   begin
      --  Find corresponding package specification, and establish the current
      --  scope. The visible defining entity for the package is the defining
      --  occurrence in the spec. On exit from the package body, all body
      --  declarations are attached to the defining entity for the body, but
      --  the later is never used for name resolution. In this fashion there
      --  is only one visible entity that denotes the package.

      --  Set Body_Id. Note that this Will be reset to point to the generic
      --  copy later on in the generic case.

      Body_Id := Defining_Entity (N);

      if Present (Corresponding_Spec (N)) then

         --  Body is body of package instantiation. Corresponding spec has
         --  already been set.

         Spec_Id := Corresponding_Spec (N);
         Pack_Decl := Unit_Declaration_Node (Spec_Id);

      else
         Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));

         if Present (Spec_Id)
           and then Is_Package_Or_Generic_Package (Spec_Id)
         then
            Pack_Decl := Unit_Declaration_Node (Spec_Id);

            if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
               Error_Msg_N ("cannot supply body for package renaming", N);
               return;

            elsif Present (Corresponding_Body (Pack_Decl)) then
               Error_Msg_N ("redefinition of package body", N);
               return;
            end if;

         else
            Error_Msg_N ("missing specification for package body", N);
            return;
         end if;

         if Is_Package_Or_Generic_Package (Spec_Id)
           and then
             (Scope (Spec_Id) = Standard_Standard
               or else Is_Child_Unit (Spec_Id))
           and then not Unit_Requires_Body (Spec_Id)
         then
            if Ada_Version = Ada_83 then
               Error_Msg_N
                 ("optional package body (not allowed in Ada 95)?", N);
            else
               Error_Msg_N
                 ("spec of this package does not allow a body", N);
            end if;
         end if;
      end if;

      Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
      Style.Check_Identifier (Body_Id, Spec_Id);

      if Is_Child_Unit (Spec_Id) then
         if Nkind (Parent (N)) /= N_Compilation_Unit then
            Error_Msg_NE
              ("body of child unit& cannot be an inner package", N, Spec_Id);
         end if;

         Set_Is_Child_Unit (Body_Id);
      end if;

      --  Generic package case

      if Ekind (Spec_Id) = E_Generic_Package then

         --  Disable expansion and perform semantic analysis on copy. The
         --  unannotated body will be used in all instantiations.

         Body_Id := Defining_Entity (N);
         Set_Ekind (Body_Id, E_Package_Body);
         Set_Scope (Body_Id, Scope (Spec_Id));
         Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
         Set_Body_Entity (Spec_Id, Body_Id);
         Set_Spec_Entity (Body_Id, Spec_Id);

         New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
         Rewrite (N, New_N);

         --  Update Body_Id to point to the copied node for the remainder of
         --  the processing.

         Body_Id := Defining_Entity (N);
         Start_Generic;
      end if;

      --  The Body_Id is that of the copied node in the generic case, the
      --  current node otherwise. Note that N was rewritten above, so we must
      --  be sure to get the latest Body_Id value.

      Set_Ekind (Body_Id, E_Package_Body);
      Set_Body_Entity (Spec_Id, Body_Id);
      Set_Spec_Entity (Body_Id, Spec_Id);

      --  Defining name for the package body is not a visible entity: Only the
      --  defining name for the declaration is visible.

      Set_Etype (Body_Id, Standard_Void_Type);
      Set_Scope (Body_Id, Scope (Spec_Id));
      Set_Corresponding_Spec (N, Spec_Id);
      Set_Corresponding_Body (Pack_Decl, Body_Id);

      --  The body entity is not used for semantics or code generation, but
      --  it is attached to the entity list of the enclosing scope to simplify
      --  the listing of back-annotations for the types it main contain.

      if Scope (Spec_Id) /= Standard_Standard then
         Append_Entity (Body_Id, Scope (Spec_Id));
      end if;

      --  Indicate that we are currently compiling the body of the package

      Set_In_Package_Body (Spec_Id);
      Set_Has_Completion (Spec_Id);
      Last_Spec_Entity := Last_Entity (Spec_Id);

      Push_Scope (Spec_Id);

      Set_Categorization_From_Pragmas (N);

      Install_Visible_Declarations (Spec_Id);
      Install_Private_Declarations (Spec_Id);
      Install_Private_With_Clauses (Spec_Id);
      Install_Composite_Operations (Spec_Id);

      Check_Anonymous_Access_Types (Spec_Id, N);

      if Ekind (Spec_Id) = E_Generic_Package then
         Set_Use (Generic_Formal_Declarations (Pack_Decl));
      end if;

      Set_Use (Visible_Declarations (Specification (Pack_Decl)));
      Set_Use (Private_Declarations (Specification (Pack_Decl)));

      --  This is a nested package, so it may be necessary to declare certain
      --  inherited subprograms that are not yet visible because the parent
      --  type's subprograms are now visible.

      if Ekind (Scope (Spec_Id)) = E_Package
        and then Scope (Spec_Id) /= Standard_Standard
      then
         Declare_Inherited_Private_Subprograms (Spec_Id);
      end if;

      if Present (Declarations (N)) then
         Analyze_Declarations (Declarations (N));
         Inspect_Deferred_Constant_Completion (Declarations (N));
      end if;

      --  Analyze_Declarations has caused freezing of all types. Now generate
      --  bodies for RACW primitives and stream attributes, if any.

      if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then

         --  Attach subprogram bodies to support RACWs declared in spec

         Append_RACW_Bodies (Declarations (N), Spec_Id);
         Analyze_List (Declarations (N));
      end if;

      HSS := Handled_Statement_Sequence (N);

      if Present (HSS) then
         Process_End_Label (HSS, 't', Spec_Id);
         Analyze (HSS);

         --  Check that elaboration code in a preelaborable package body is
         --  empty other than null statements and labels (RM 10.2.1(6)).

         Validate_Null_Statement_Sequence (N);
      end if;

      Validate_Categorization_Dependency (N, Spec_Id);
      Check_Completion (Body_Id);

      --  Generate start of body reference. Note that we do this fairly late,
      --  because the call will use In_Extended_Main_Source_Unit as a check,
      --  and we want to make sure that Corresponding_Stub links are set

      Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);

      --  For a generic package, collect global references and mark them on
      --  the original body so that they are not resolved again at the point
      --  of instantiation.

      if Ekind (Spec_Id) /= E_Package then
         Save_Global_References (Original_Node (N));
         End_Generic;
      end if;

      --  The entities of the package body have so far been chained onto the
      --  declaration chain for the spec. That's been fine while we were in the
      --  body, since we wanted them to be visible, but now that we are leaving
      --  the package body, they are no longer visible, so we remove them from
      --  the entity chain of the package spec entity, and copy them to the
      --  entity chain of the package body entity, where they will never again
      --  be visible.

      if Present (Last_Spec_Entity) then
         Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
         Set_Next_Entity (Last_Spec_Entity, Empty);
         Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
         Set_Last_Entity (Spec_Id, Last_Spec_Entity);

      else
         Set_First_Entity (Body_Id, First_Entity (Spec_Id));
         Set_Last_Entity  (Body_Id, Last_Entity  (Spec_Id));
         Set_First_Entity (Spec_Id, Empty);
         Set_Last_Entity  (Spec_Id, Empty);
      end if;

      End_Package_Scope (Spec_Id);

      --  All entities declared in body are not visible

      declare
         E : Entity_Id;

      begin
         E := First_Entity (Body_Id);
         while Present (E) loop
            Set_Is_Immediately_Visible (E, False);
            Set_Is_Potentially_Use_Visible (E, False);
            Set_Is_Hidden (E);

            --  Child units may appear on the entity list (e.g. if they appear
            --  in the context of a subunit) but they are not body entities.

            if not Is_Child_Unit (E) then
               Set_Is_Package_Body_Entity (E);
            end if;

            Next_Entity (E);
         end loop;
      end;

      Check_References (Body_Id);

      --  For a generic unit, check that the formal parameters are referenced,
      --  and that local variables are used, as for regular packages.

      if Ekind (Spec_Id) = E_Generic_Package then
         Check_References (Spec_Id);
      end if;

      --  The processing so far has made all entities of the package body
      --  public (i.e. externally visible to the linker). This is in general
      --  necessary, since inlined or generic bodies, for which code is
      --  generated in other units, may need to see these entities. The
      --  following loop runs backwards from the end of the entities of the
      --  package body making these entities invisible until we reach a
      --  referencer, i.e. a declaration that could reference a previous
      --  declaration, a generic body or an inlined body, or a stub (which may
      --  contain either of these). This is of course an approximation, but it
      --  is conservative and definitely correct.

      --  We only do this at the outer (library) level non-generic packages.
      --  The reason is simply to cut down on the number of external symbols
      --  generated, so this is simply an optimization of the efficiency
      --  of the compilation process. It has no other effect.

      if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
        and then not Is_Generic_Unit (Spec_Id)
        and then Present (Declarations (N))
      then
         Make_Non_Public_Where_Possible : declare

            function Has_Referencer
              (L     : List_Id;
               Outer : Boolean)
               return  Boolean;
            --  Traverse the given list of declarations in reverse order.
            --  Return True as soon as a referencer is reached. Return False if
            --  none is found. The Outer parameter is True for the outer level
            --  call, and False for inner level calls for nested packages. If
            --  Outer is True, then any entities up to the point of hitting a
            --  referencer get their Is_Public flag cleared, so that the
            --  entities will be treated as static entities in the C sense, and
            --  need not have fully qualified names. For inner levels, we need
            --  all names to be fully qualified to deal with the same name
            --  appearing in parallel packages (right now this is tied to their
            --  being external).

            --------------------
            -- Has_Referencer --
            --------------------

            function Has_Referencer
              (L     : List_Id;
               Outer : Boolean)
               return  Boolean
            is
               D : Node_Id;
               E : Entity_Id;
               K : Node_Kind;
               S : Entity_Id;

            begin
               if No (L) then
                  return False;
               end if;

               D := Last (L);
               while Present (D) loop
                  K := Nkind (D);

                  if K in N_Body_Stub then
                     return True;

                  elsif K = N_Subprogram_Body then
                     if Acts_As_Spec (D) then
                        E := Defining_Entity (D);

                        --  An inlined body acts as a referencer. Note also
                        --  that we never reset Is_Public for an inlined
                        --  subprogram. Gigi requires Is_Public to be set.

                        --  Note that we test Has_Pragma_Inline here rather
                        --  than Is_Inlined. We are compiling this for a
                        --  client, and it is the client who will decide if
                        --  actual inlining should occur, so we need to assume
                        --  that the procedure could be inlined for the purpose
                        --  of accessing global entities.

                        if Has_Pragma_Inline (E) then
                           return True;
                        else
                           Set_Is_Public (E, False);
                        end if;

                     else
                        E := Corresponding_Spec (D);

                        if Present (E)
                          and then (Is_Generic_Unit (E)
                                     or else Has_Pragma_Inline (E)
                                     or else Is_Inlined (E))
                        then
                           return True;
                        end if;
                     end if;

                  --  Processing for package bodies

                  elsif K = N_Package_Body
                    and then Present (Corresponding_Spec (D))
                  then
                     E := Corresponding_Spec (D);

                     --  Generic package body is a referencer. It would seem
                     --  that we only have to consider generics that can be
                     --  exported, i.e. where the corresponding spec is the
                     --  spec of the current package, but because of nested
                     --  instantiations, a fully private generic body may
                     --  export other private body entities.

                     if Is_Generic_Unit (E) then
                        return True;

                     --  For non-generic package body, recurse into body unless
                     --  this is an instance, we ignore instances since they
                     --  cannot have references that affect outer entities.

                     elsif not Is_Generic_Instance (E) then
                        if Has_Referencer
                             (Declarations (D), Outer => False)
                        then
                           return True;
                        end if;
                     end if;

                  --  Processing for package specs, recurse into declarations.
                  --  Again we skip this for the case of generic instances.

                  elsif K = N_Package_Declaration then
                     S := Specification (D);

                     if not Is_Generic_Unit (Defining_Entity (S)) then
                        if Has_Referencer
                             (Private_Declarations (S), Outer => False)
                        then
                           return True;
                        elsif Has_Referencer
                               (Visible_Declarations (S), Outer => False)
                        then
                           return True;
                        end if;
                     end if;

                  --  Objects and exceptions need not be public if we have not
                  --  encountered a referencer so far. We only reset the flag
                  --  for outer level entities that are not imported/exported,
                  --  and which have no interface name.

                  elsif Nkind_In (K, N_Object_Declaration,
                                     N_Exception_Declaration,
                                     N_Subprogram_Declaration)
                  then
                     E := Defining_Entity (D);

                     if Outer
                       and then not Is_Imported (E)
                       and then not Is_Exported (E)
                       and then No (Interface_Name (E))
                     then
                        Set_Is_Public (E, False);
                     end if;
                  end if;

                  Prev (D);
               end loop;

               return False;
            end Has_Referencer;

         --  Start of processing for Make_Non_Public_Where_Possible

         begin
            declare
               Discard : Boolean;
               pragma Warnings (Off, Discard);

            begin
               Discard := Has_Referencer (Declarations (N), Outer => True);
            end;
         end Make_Non_Public_Where_Possible;
      end if;

      --  If expander is not active, then here is where we turn off the
      --  In_Package_Body flag, otherwise it is turned off at the end of the
      --  corresponding expansion routine. If this is an instance body, we need
      --  to qualify names of local entities, because the body may have been
      --  compiled as a preliminary to another instantiation.

      if not Expander_Active then
         Set_In_Package_Body (Spec_Id, False);

         if Is_Generic_Instance (Spec_Id)
           and then Operating_Mode = Generate_Code
         then
            Qualify_Entity_Names (N);
         end if;
      end if;
   end Analyze_Package_Body_Helper;

   ---------------------------------
   -- Analyze_Package_Declaration --
   ---------------------------------

   procedure Analyze_Package_Declaration (N : Node_Id) is
      Id : constant Node_Id := Defining_Entity (N);

      PF : Boolean;
      --  True when in the context of a declared pure library unit

      Body_Required : Boolean;
      --  True when this package declaration requires a corresponding body

      Comp_Unit : Boolean;
      --  True when this package declaration is not a nested declaration

   begin
      --  Ada 2005 (AI-217): Check if the package has been erroneously named
      --  in a limited-with clause of its own context. In this case the error
      --  has been previously notified by Analyze_Context.

      --     limited with Pkg; -- ERROR
      --     package Pkg is ...

      if From_With_Type (Id) then
         return;
      end if;

      if Debug_Flag_C then
         Write_Str ("==> package spec ");
         Write_Name (Chars (Id));
         Write_Str (" from ");
         Write_Location (Sloc (N));
         Write_Eol;
         Indent;
      end if;

      Generate_Definition (Id);
      Enter_Name (Id);
      Set_Ekind (Id, E_Package);
      Set_Etype (Id, Standard_Void_Type);

      Push_Scope (Id);

      PF := Is_Pure (Enclosing_Lib_Unit_Entity);
      Set_Is_Pure (Id, PF);

      Set_Categorization_From_Pragmas (N);

      Analyze (Specification (N));
      Validate_Categorization_Dependency (N, Id);

      Body_Required := Unit_Requires_Body (Id);

      --  When this spec does not require an explicit body, we know that there
      --  are no entities requiring completion in the language sense; we call
      --  Check_Completion here only to ensure that any nested package
      --  declaration that requires an implicit body gets one. (In the case
      --  where a body is required, Check_Completion is called at the end of
      --  the body's declarative part.)

      if not Body_Required then
         Check_Completion;
      end if;

      Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit;
      if Comp_Unit then

         --  Set Body_Required indication on the compilation unit node, and
         --  determine whether elaboration warnings may be meaningful on it.

         Set_Body_Required (Parent (N), Body_Required);

         if not Body_Required then
            Set_Suppress_Elaboration_Warnings (Id);
         end if;

      end if;

      End_Package_Scope (Id);

      --  For the declaration of a library unit that is a remote types package,
      --  check legality rules regarding availability of stream attributes for
      --  types that contain non-remote access values. This subprogram performs
      --  visibility tests that rely on the fact that we have exited the scope
      --  of Id.

      if Comp_Unit then
         Validate_RT_RAT_Component (N);
      end if;

      if Debug_Flag_C then
         Outdent;
         Write_Str ("<== package spec ");
         Write_Name (Chars (Id));
         Write_Str (" from ");
         Write_Location (Sloc (N));
         Write_Eol;
      end if;
   end Analyze_Package_Declaration;

   -----------------------------------
   -- Analyze_Package_Specification --
   -----------------------------------

   --  Note that this code is shared for the analysis of generic package specs
   --  (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).

   procedure Analyze_Package_Specification (N : Node_Id) is
      Id           : constant Entity_Id  := Defining_Entity (N);
      Orig_Decl    : constant Node_Id    := Original_Node (Parent (N));
      Vis_Decls    : constant List_Id    := Visible_Declarations (N);
      Priv_Decls   : constant List_Id    := Private_Declarations (N);
      E            : Entity_Id;
      L            : Entity_Id;
      Public_Child : Boolean;

      Private_With_Clauses_Installed : Boolean := False;
      --  In Ada 2005, private with_clauses are visible in the private part
      --  of a nested package, even if it appears in the public part of the
      --  enclosing package. This requires a separate step to install these
      --  private_with_clauses, and remove them at the end of the nested
      --  package.

      procedure Analyze_PPCs (Decls : List_Id);
      --  Given a list of declarations, go through looking for subprogram
      --  specs, and for each one found, analyze any pre/postconditions that
      --  are chained to the spec. This is the implementation of the late
      --  visibility analysis for preconditions and postconditions in specs.

      procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
      --  Clears constant indications (Never_Set_In_Source, Constant_Value, and
      --  Is_True_Constant) on all variables that are entities of Id, and on
      --  the chain whose first element is FE. A recursive call is made for all
      --  packages and generic packages.

      procedure Generate_Parent_References;
      --  For a child unit, generate references to parent units, for
      --  GPS navigation purposes.

      function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
      --  Child and Unit are entities of compilation units. True if Child
      --  is a public child of Parent as defined in 10.1.1

      procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
      --  Detects all incomplete or private type declarations having a known
      --  discriminant part that are completed by an Unchecked_Union. Emits
      --  the error message "Unchecked_Union may not complete discriminated
      --  partial view".

      procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id);
      --  Given the package entity of a generic package instantiation or
      --  formal package whose corresponding generic is a child unit, installs
      --  the private declarations of each of the child unit's parents.
      --  This has to be done at the point of entering the instance package's
      --  private part rather than being done in Sem_Ch12.Install_Parent
      --  (which is where the parents' visible declarations are installed).

      ------------------
      -- Analyze_PPCs --
      ------------------

      procedure Analyze_PPCs (Decls : List_Id) is
         Decl : Node_Id;
         Spec : Node_Id;
         Sent : Entity_Id;
         Prag : Node_Id;

      begin
         Decl := First (Decls);
         while Present (Decl) loop
            if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
               Spec := Specification (Original_Node (Decl));
               Sent := Defining_Unit_Name (Spec);
               Prag := Spec_PPC_List (Sent);
               while Present (Prag) loop
                  Analyze_PPC_In_Decl_Part (Prag, Sent);
                  Prag := Next_Pragma (Prag);
               end loop;
            end if;

            Next (Decl);
         end loop;
      end Analyze_PPCs;

      ---------------------
      -- Clear_Constants --
      ---------------------

      procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
         E : Entity_Id;

      begin
         --  Ignore package renamings, not interesting and they can cause self
         --  referential loops in the code below.

         if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
            return;
         end if;

         --  Note: in the loop below, the check for Next_Entity pointing back
         --  to the package entity may seem odd, but it is needed, because a
         --  package can contain a renaming declaration to itself, and such
         --  renamings are generated automatically within package instances.

         E := FE;
         while Present (E) and then E /= Id loop
            if Is_Assignable (E) then
               Set_Never_Set_In_Source (E, False);
               Set_Is_True_Constant    (E, False);
               Set_Current_Value       (E, Empty);
               Set_Is_Known_Null       (E, False);
               Set_Last_Assignment     (E, Empty);

               if not Can_Never_Be_Null (E) then
                  Set_Is_Known_Non_Null (E, False);
               end if;

            elsif Is_Package_Or_Generic_Package (E) then
               Clear_Constants (E, First_Entity (E));
               Clear_Constants (E, First_Private_Entity (E));
            end if;

            Next_Entity (E);
         end loop;
      end Clear_Constants;

      --------------------------------
      -- Generate_Parent_References --
      --------------------------------

      procedure Generate_Parent_References is
         Decl : constant Node_Id := Parent (N);

      begin
         if Id = Cunit_Entity (Main_Unit)
           or else Parent (Decl) = Library_Unit (Cunit (Main_Unit))
         then
            Generate_Reference (Id, Scope (Id), 'k', False);

         elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
                                                       N_Subunit)
         then
            --  If current unit is an ancestor of main unit, generate a
            --  reference to its own parent.

            declare
               U         : Node_Id;
               Main_Spec : Node_Id := Unit (Cunit (Main_Unit));

            begin
               if Nkind (Main_Spec) = N_Package_Body then
                  Main_Spec := Unit (Library_Unit (Cunit (Main_Unit)));
               end if;

               U := Parent_Spec (Main_Spec);
               while Present (U) loop
                  if U = Parent (Decl) then
                     Generate_Reference (Id, Scope (Id), 'k',  False);
                     exit;

                  elsif Nkind (Unit (U)) = N_Package_Body then
                     exit;

                  else
                     U := Parent_Spec (Unit (U));
                  end if;
               end loop;
            end;
         end if;
      end Generate_Parent_References;

      ---------------------
      -- Is_Public_Child --
      ---------------------

      function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
      begin
         if not Is_Private_Descendant (Child) then
            return True;
         else
            if Child = Unit then
               return not Private_Present (
                 Parent (Unit_Declaration_Node (Child)));
            else
               return Is_Public_Child (Scope (Child), Unit);
            end if;
         end if;
      end Is_Public_Child;

      ----------------------------------------
      -- Inspect_Unchecked_Union_Completion --
      ----------------------------------------

      procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
         Decl : Node_Id;

      begin
         Decl := First (Decls);
         while Present (Decl) loop

            --  We are looking at an incomplete or private type declaration
            --  with a known_discriminant_part whose full view is an
            --  Unchecked_Union.

            if Nkind_In (Decl, N_Incomplete_Type_Declaration,
                               N_Private_Type_Declaration)
              and then Has_Discriminants (Defining_Identifier (Decl))
              and then Present (Full_View (Defining_Identifier (Decl)))
              and then
                Is_Unchecked_Union (Full_View (Defining_Identifier (Decl)))
            then
               Error_Msg_N
                 ("completion of discriminated partial view "
                  & "cannot be an Unchecked_Union",
                 Full_View (Defining_Identifier (Decl)));
            end if;

            Next (Decl);
         end loop;
      end Inspect_Unchecked_Union_Completion;

      -----------------------------------------
      -- Install_Parent_Private_Declarations --
      -----------------------------------------

      procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is
         Inst_Par  : Entity_Id;
         Gen_Par   : Entity_Id;
         Inst_Node : Node_Id;

      begin
         Inst_Par := Inst_Id;

         Gen_Par :=
           Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
         while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
            Inst_Node := Get_Package_Instantiation_Node (Inst_Par);

            if Nkind_In (Inst_Node, N_Package_Instantiation,
                                    N_Formal_Package_Declaration)
              and then Nkind (Name (Inst_Node)) = N_Expanded_Name
            then
               Inst_Par := Entity (Prefix (Name (Inst_Node)));

               if Present (Renamed_Entity (Inst_Par)) then
                  Inst_Par := Renamed_Entity (Inst_Par);
               end if;

               Gen_Par :=
                 Generic_Parent
                   (Specification (Unit_Declaration_Node (Inst_Par)));

               --  Install the private declarations and private use clauses
               --  of a parent instance of the child instance, unless the
               --  parent instance private declarations have already been
               --  installed earlier in Analyze_Package_Specification, which
               --  happens when a generic child is instantiated, and the
               --  instance is a child of the parent instance.

               --  Installing the use clauses of the parent instance twice
               --  is both unnecessary and wrong, because it would cause the
               --  clauses to be chained to themselves in the use clauses
               --  list of the scope stack entry. That in turn would cause
               --  an endless loop from End_Use_Clauses upon scope exit.

               --  The parent is now fully visible. It may be a hidden open
               --  scope if we are currently compiling some child instance
               --  declared within it, but while the current instance is being
               --  compiled the parent is immediately visible. In particular
               --  its entities must remain visible if a stack save/restore
               --  takes place through a call to Rtsfind.

               if Present (Gen_Par) then
                  if not In_Private_Part (Inst_Par) then
                     Install_Private_Declarations (Inst_Par);
                     Set_Use (Private_Declarations
                                (Specification
                                   (Unit_Declaration_Node (Inst_Par))));
                     Set_Is_Hidden_Open_Scope (Inst_Par, False);
                  end if;

               --  If we've reached the end of the generic instance parents,
               --  then finish off by looping through the nongeneric parents
               --  and installing their private declarations.

               else
                  while Present (Inst_Par)
                    and then Inst_Par /= Standard_Standard
                    and then (not In_Open_Scopes (Inst_Par)
                                or else not In_Private_Part (Inst_Par))
                  loop
                     Install_Private_Declarations (Inst_Par);
                     Set_Use (Private_Declarations
                                (Specification
                                   (Unit_Declaration_Node (Inst_Par))));
                     Inst_Par := Scope (Inst_Par);
                  end loop;

                  exit;
               end if;

            else
               exit;
            end if;
         end loop;
      end Install_Parent_Private_Declarations;

   --  Start of processing for Analyze_Package_Specification

   begin
      if Present (Vis_Decls) then
         Analyze_Declarations (Vis_Decls);
         Analyze_PPCs (Vis_Decls);
      end if;

      --  Verify that incomplete types have received full declarations

      E := First_Entity (Id);
      while Present (E) loop
         if Ekind (E) = E_Incomplete_Type
           and then No (Full_View (E))
         then
            Error_Msg_N ("no declaration in visible part for incomplete}", E);
         end if;

         Next_Entity (E);
      end loop;

      if Is_Remote_Call_Interface (Id)
         and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
      then
         Validate_RCI_Declarations (Id);
      end if;

      --  Save global references in the visible declarations, before installing
      --  private declarations of parent unit if there is one, because the
      --  privacy status of types defined in the parent will change. This is
      --  only relevant for generic child units, but is done in all cases for
      --  uniformity.

      if Ekind (Id) = E_Generic_Package
        and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
      then
         declare
            Orig_Spec : constant Node_Id := Specification (Orig_Decl);
            Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);

         begin
            Set_Private_Declarations (Orig_Spec, Empty_List);
            Save_Global_References   (Orig_Decl);
            Set_Private_Declarations (Orig_Spec, Save_Priv);
         end;
      end if;

      --  If package is a public child unit, then make the private declarations
      --  of the parent visible.

      Public_Child := False;

      declare
         Par       : Entity_Id;
         Pack_Decl : Node_Id;
         Par_Spec  : Node_Id;

      begin
         Par := Id;
         Par_Spec := Parent_Spec (Parent (N));

         --  If the package is formal package of an enclosing generic, it is
         --  transformed into a local generic declaration, and compiled to make
         --  its spec available. We need to retrieve the original generic to
         --  determine whether it is a child unit, and install its parents.

         if No (Par_Spec)
           and then
             Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration
         then
            Par := Entity (Name (Original_Node (Parent (N))));
            Par_Spec := Parent_Spec (Unit_Declaration_Node (Par));
         end if;

         if Present (Par_Spec) then
            Generate_Parent_References;

            while Scope (Par) /= Standard_Standard
              and then Is_Public_Child (Id, Par)
              and then In_Open_Scopes (Par)
            loop
               Public_Child := True;
               Par := Scope (Par);
               Install_Private_Declarations (Par);
               Install_Private_With_Clauses (Par);
               Pack_Decl := Unit_Declaration_Node (Par);
               Set_Use (Private_Declarations (Specification (Pack_Decl)));
            end loop;
         end if;
      end;

      if Is_Compilation_Unit (Id) then
         Install_Private_With_Clauses (Id);
      else

         --  The current compilation unit may include private with_clauses,
         --  which are visible in the private part of the current nested
         --  package, and have to be installed now. This is not done for
         --  nested instantiations, where the private with_clauses of the
         --  enclosing unit have no effect once the instantiation info is
         --  established and we start analyzing the package declaration.

         declare
            Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
         begin
            if Is_Package_Or_Generic_Package (Comp_Unit)
              and then not In_Private_Part (Comp_Unit)
              and then not In_Instance
            then
               Install_Private_With_Clauses (Comp_Unit);
               Private_With_Clauses_Installed := True;
            end if;
         end;
      end if;

      --  If this is a package associated with a generic instance or formal
      --  package, then the private declarations of each of the generic's
      --  parents must be installed at this point.

      if Is_Generic_Instance (Id) then
         Install_Parent_Private_Declarations (Id);
      end if;

      --  Analyze private part if present. The flag In_Private_Part is reset
      --  in End_Package_Scope.

      L := Last_Entity (Id);

      if Present (Priv_Decls) then
         Set_In_Private_Part (Id);

         --  Upon entering a public child's private part, it may be necessary
         --  to declare subprograms that were derived in the package's visible
         --  part but not yet made visible.

         if Public_Child then
            Declare_Inherited_Private_Subprograms (Id);
         end if;

         Analyze_Declarations (Priv_Decls);
         Analyze_PPCs (Priv_Decls);

         --  Check the private declarations for incomplete deferred constants

         Inspect_Deferred_Constant_Completion (Priv_Decls);

         --  The first private entity is the immediate follower of the last
         --  visible entity, if there was one.

         if Present (L) then
            Set_First_Private_Entity (Id, Next_Entity (L));
         else
            Set_First_Private_Entity (Id, First_Entity (Id));
         end if;

      --  There may be inherited private subprograms that need to be declared,
      --  even in the absence of an explicit private part.  If there are any
      --  public declarations in the package and the package is a public child
      --  unit, then an implicit private part is assumed.

      elsif Present (L) and then Public_Child then
         Set_In_Private_Part (Id);
         Declare_Inherited_Private_Subprograms (Id);
         Set_First_Private_Entity (Id, Next_Entity (L));
      end if;

      E := First_Entity (Id);
      while Present (E) loop

         --  Check rule of 3.6(11), which in general requires waiting till all
         --  full types have been seen.

         if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
            Check_Aliased_Component_Types (E);
         end if;

         --  Check preelaborable initialization for full type completing a
         --  private type for which pragma Preelaborable_Initialization given.

         if Is_Type (E)
           and then Must_Have_Preelab_Init (E)
           and then not Has_Preelaborable_Initialization (E)
         then
            Error_Msg_N
              ("full view of & does not have preelaborable initialization", E);
         end if;

         Next_Entity (E);
      end loop;

      --  Ada 2005 (AI-216): The completion of an incomplete or private type
      --  declaration having a known_discriminant_part shall not be an
      --  Unchecked_Union type.

      if Present (Vis_Decls) then
         Inspect_Unchecked_Union_Completion (Vis_Decls);
      end if;

      if Present (Priv_Decls) then
         Inspect_Unchecked_Union_Completion (Priv_Decls);
      end if;

      if Ekind (Id) = E_Generic_Package
        and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
        and then Present (Priv_Decls)
      then
         --  Save global references in private declarations, ignoring the
         --  visible declarations that were processed earlier.

         declare
            Orig_Spec : constant Node_Id := Specification (Orig_Decl);
            Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
            Save_Form : constant List_Id :=
                          Generic_Formal_Declarations (Orig_Decl);

         begin
            Set_Visible_Declarations        (Orig_Spec, Empty_List);
            Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
            Save_Global_References          (Orig_Decl);
            Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
            Set_Visible_Declarations        (Orig_Spec, Save_Vis);
         end;
      end if;

      Process_End_Label (N, 'e', Id);

      --  Remove private_with_clauses of enclosing compilation unit, if they
      --  were installed.

      if Private_With_Clauses_Installed then
         Remove_Private_With_Clauses (Cunit (Current_Sem_Unit));
      end if;

      --  For the case of a library level package, we must go through all the
      --  entities clearing the indications that the value may be constant and
      --  not modified. Why? Because any client of this package may modify
      --  these values freely from anywhere. This also applies to any nested
      --  packages or generic packages.

      --  For now we unconditionally clear constants for packages that are
      --  instances of generic packages. The reason is that we do not have the
      --  body yet, and we otherwise think things are unreferenced when they
      --  are not. This should be fixed sometime (the effect is not terrible,
      --  we just lose some warnings, and also some cases of value propagation)
      --  ???

      if Is_Library_Level_Entity (Id)
        or else Is_Generic_Instance (Id)
      then
         Clear_Constants (Id, First_Entity (Id));
         Clear_Constants (Id, First_Private_Entity (Id));
      end if;
   end Analyze_Package_Specification;

   --------------------------------------
   -- Analyze_Private_Type_Declaration --
   --------------------------------------

   procedure Analyze_Private_Type_Declaration (N : Node_Id) is
      PF : constant Boolean   := Is_Pure (Enclosing_Lib_Unit_Entity);
      Id : constant Entity_Id := Defining_Identifier (N);

   begin
      Generate_Definition (Id);
      Set_Is_Pure         (Id, PF);
      Init_Size_Align     (Id);

      if not Is_Package_Or_Generic_Package (Current_Scope)
        or else In_Private_Part (Current_Scope)
      then
         Error_Msg_N ("invalid context for private declaration", N);
      end if;

      New_Private_Type (N, Id, N);
      Set_Depends_On_Private (Id);
   end Analyze_Private_Type_Declaration;

   ----------------------------------
   -- Check_Anonymous_Access_Types --
   ----------------------------------

   procedure Check_Anonymous_Access_Types
     (Spec_Id : Entity_Id;
      P_Body  : Node_Id)
   is
      E  : Entity_Id;
      IR : Node_Id;

   begin
      --  Itype references are only needed by gigi, to force elaboration of
      --  itypes. In the absence of code generation, they are not needed.

      if not Expander_Active then
         return;
      end if;

      E := First_Entity (Spec_Id);
      while Present (E) loop
         if Ekind (E) = E_Anonymous_Access_Type
           and then From_With_Type (E)
         then
            IR := Make_Itype_Reference (Sloc (P_Body));
            Set_Itype (IR, E);

            if No (Declarations (P_Body)) then
               Set_Declarations (P_Body, New_List (IR));
            else
               Prepend (IR, Declarations (P_Body));
            end if;
         end if;

         Next_Entity (E);
      end loop;
   end Check_Anonymous_Access_Types;

   -------------------------------------------
   -- Declare_Inherited_Private_Subprograms --
   -------------------------------------------

   procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is

      function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
      --  Check whether an inherited subprogram is an operation of an untagged
      --  derived type.

      ---------------------
      -- Is_Primitive_Of --
      ---------------------

      function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
         Formal : Entity_Id;

      begin
         --  If the full view is a scalar type, the type is the anonymous base
         --  type, but the operation mentions the first subtype, so check the
         --  signature against the base type.

         if Base_Type (Etype (S)) = Base_Type (T) then
            return True;

         else
            Formal := First_Formal (S);
            while Present (Formal) loop
               if Base_Type (Etype (Formal)) = Base_Type (T) then
                  return True;
               end if;

               Next_Formal (Formal);
            end loop;

            return False;
         end if;
      end Is_Primitive_Of;

      --  Local variables

      E           : Entity_Id;
      Op_List     : Elist_Id;
      Op_Elmt     : Elmt_Id;
      Op_Elmt_2   : Elmt_Id;
      Prim_Op     : Entity_Id;
      New_Op      : Entity_Id := Empty;
      Parent_Subp : Entity_Id;
      Tag         : Entity_Id;

   --  Start of processing for Declare_Inherited_Private_Subprograms

   begin
      E := First_Entity (Id);
      while Present (E) loop

         --  If the entity is a nonprivate type extension whose parent type
         --  is declared in an open scope, then the type may have inherited
         --  operations that now need to be made visible. Ditto if the entity
         --  is a formal derived type in a child unit.

         if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
               or else
                 (Nkind (Parent (E)) = N_Private_Extension_Declaration
                   and then Is_Generic_Type (E)))
           and then In_Open_Scopes (Scope (Etype (E)))
           and then E = Base_Type (E)
         then
            if Is_Tagged_Type (E) then
               Op_List := Primitive_Operations (E);
               New_Op  := Empty;
               Tag     := First_Tag_Component (E);

               Op_Elmt := First_Elmt (Op_List);
               while Present (Op_Elmt) loop
                  Prim_Op := Node (Op_Elmt);

                  --  Search primitives that are implicit operations with an
                  --  internal name whose parent operation has a normal name.

                  if Present (Alias (Prim_Op))
                    and then Find_Dispatching_Type (Alias (Prim_Op)) /= E
                    and then not Comes_From_Source (Prim_Op)
                    and then Is_Internal_Name (Chars (Prim_Op))
                    and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
                  then
                     Parent_Subp := Alias (Prim_Op);

                     --  Case 1: Check if the type has also an explicit
                     --  overriding for this primitive.

                     Op_Elmt_2 := Next_Elmt (Op_Elmt);
                     while Present (Op_Elmt_2) loop
                        if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
                          and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
                        then
                           --  The private inherited operation has been
                           --  overridden by an explicit subprogram: replace
                           --  the former by the latter.

                           New_Op := Node (Op_Elmt_2);
                           Replace_Elmt (Op_Elmt, New_Op);
                           Remove_Elmt  (Op_List, Op_Elmt_2);
                           Set_Is_Overriding_Operation (New_Op);
                           Set_Overridden_Operation (New_Op, Parent_Subp);

                           --  We don't need to inherit its dispatching slot.
                           --  Set_All_DT_Position has previously ensured that
                           --  the same slot was assigned to the two primitives

                           if Present (Tag)
                             and then Present (DTC_Entity (New_Op))
                             and then Present (DTC_Entity (Prim_Op))
                           then
                              pragma Assert (DT_Position (New_Op)
                                              = DT_Position (Prim_Op));
                              null;
                           end if;

                           goto Next_Primitive;
                        end if;

                        Next_Elmt (Op_Elmt_2);
                     end loop;

                     --   Case 2: We have not found any explicit overriding and
                     --   hence we need to declare the operation (i.e., make it
                     --   visible).

                     Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));

                     --  Inherit the dispatching slot if E is already frozen

                     if Is_Frozen (E)
                       and then Present (DTC_Entity (Alias (Prim_Op)))
                     then
                        Set_DTC_Entity_Value (E, New_Op);
                        Set_DT_Position (New_Op,
                          DT_Position (Alias (Prim_Op)));
                     end if;

                     pragma Assert
                       (Is_Dispatching_Operation (New_Op)
                         and then Node (Last_Elmt (Op_List)) = New_Op);

                     --  Substitute the new operation for the old one in the
                     --  type's primitive operations list. Since the new
                     --  operation was also just added to the end of list,
                     --  the last element must be removed.

                     --  (Question: is there a simpler way of declaring the
                     --  operation, say by just replacing the name of the
                     --  earlier operation, reentering it in the in the symbol
                     --  table (how?), and marking it as private???)

                     Replace_Elmt (Op_Elmt, New_Op);
                     Remove_Last_Elmt (Op_List);
                  end if;

                  <<Next_Primitive>>
                  Next_Elmt (Op_Elmt);
               end loop;

               --  Generate listing showing the contents of the dispatch table

               if Debug_Flag_ZZ then
                  Write_DT (E);
               end if;

            else
               --   Non-tagged type, scan forward to locate inherited hidden
               --   operations.

               Prim_Op := Next_Entity (E);
               while Present (Prim_Op) loop
                  if Is_Subprogram (Prim_Op)
                    and then Present (Alias (Prim_Op))
                    and then not Comes_From_Source (Prim_Op)
                    and then Is_Internal_Name (Chars (Prim_Op))
                    and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
                    and then Is_Primitive_Of (E, Prim_Op)
                  then
                     Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
                  end if;

                  Next_Entity (Prim_Op);
               end loop;
            end if;
         end if;

         Next_Entity (E);
      end loop;
   end Declare_Inherited_Private_Subprograms;

   -----------------------
   -- End_Package_Scope --
   -----------------------

   procedure End_Package_Scope (P : Entity_Id) is
   begin
      Uninstall_Declarations (P);
      Pop_Scope;
   end End_Package_Scope;

   ---------------------------
   -- Exchange_Declarations --
   ---------------------------

   procedure Exchange_Declarations (Id : Entity_Id) is
      Full_Id : constant Entity_Id := Full_View (Id);
      H1      : constant Entity_Id := Homonym (Id);
      Next1   : constant Entity_Id := Next_Entity (Id);
      H2      : Entity_Id;
      Next2   : Entity_Id;

   begin
      --  If missing full declaration for type, nothing to exchange

      if No (Full_Id) then
         return;
      end if;

      --  Otherwise complete the exchange, and preserve semantic links

      Next2 := Next_Entity (Full_Id);
      H2    := Homonym (Full_Id);

      --  Reset full declaration pointer to reflect the switched entities and
      --  readjust the next entity chains.

      Exchange_Entities (Id, Full_Id);

      Set_Next_Entity (Id, Next1);
      Set_Homonym     (Id, H1);

      Set_Full_View   (Full_Id, Id);
      Set_Next_Entity (Full_Id, Next2);
      Set_Homonym     (Full_Id, H2);
   end Exchange_Declarations;

   ----------------------------
   -- Install_Package_Entity --
   ----------------------------

   procedure Install_Package_Entity (Id : Entity_Id) is
   begin
      if not Is_Internal (Id) then
         if Debug_Flag_E then
            Write_Str ("Install: ");
            Write_Name (Chars (Id));
            Write_Eol;
         end if;

         if not Is_Child_Unit (Id) then
            Set_Is_Immediately_Visible (Id);
         end if;

      end if;
   end Install_Package_Entity;

   ----------------------------------
   -- Install_Private_Declarations --
   ----------------------------------

   procedure Install_Private_Declarations (P : Entity_Id) is
      Id        : Entity_Id;
      Priv_Elmt : Elmt_Id;
      Priv      : Entity_Id;
      Full      : Entity_Id;

   begin
      --  First exchange declarations for private types, so that the full
      --  declaration is visible. For each private type, we check its
      --  Private_Dependents list and also exchange any subtypes of or derived
      --  types from it. Finally, if this is a Taft amendment type, the
      --  incomplete declaration is irrelevant, and we want to link the
      --  eventual full declaration with the original private one so we also
      --  skip the exchange.

      Id := First_Entity (P);
      while Present (Id) and then Id /= First_Private_Entity (P) loop
         if Is_Private_Base_Type (Id)
           and then Comes_From_Source (Full_View (Id))
           and then Present (Full_View (Id))
           and then Scope (Full_View (Id)) = Scope (Id)
           and then Ekind (Full_View (Id)) /= E_Incomplete_Type
         then
            --  If there is a use-type clause on the private type, set the
            --  full view accordingly.

            Set_In_Use (Full_View (Id), In_Use (Id));
            Full := Full_View (Id);

            if Is_Private_Base_Type (Full)
              and then Has_Private_Declaration (Full)
              and then Nkind (Parent (Full)) = N_Full_Type_Declaration
              and then In_Open_Scopes (Scope (Etype (Full)))
              and then In_Package_Body (Current_Scope)
              and then not Is_Private_Type (Etype (Full))
            then
               --  This is the completion of a private type by a derivation
               --  from another private type which is not private anymore. This
               --  can only happen in a package nested within a child package,
               --  when the parent type is defined in the parent unit. At this
               --  point the current type is not private either, and we have to
               --  install the underlying full view, which is now visible. Save
               --  the current full view as well, so that all views can be
               --  restored on exit. It may seem that after compiling the child
               --  body there are not environments to restore, but the back-end
               --  expects those links to be valid, and freeze nodes depend on
               --  them.

               if No (Full_View (Full))
                 and then Present (Underlying_Full_View (Full))
               then
                  Set_Full_View (Id, Underlying_Full_View (Full));
                  Set_Underlying_Full_View (Id, Full);

                  Set_Underlying_Full_View (Full, Empty);
                  Set_Is_Frozen (Full_View (Id));
               end if;
            end if;

            Priv_Elmt := First_Elmt (Private_Dependents (Id));

            Exchange_Declarations (Id);
            Set_Is_Immediately_Visible (Id);

            while Present (Priv_Elmt) loop
               Priv := Node (Priv_Elmt);

               --  Before the exchange, verify that the presence of the
               --  Full_View field. It will be empty if the entity has already
               --  been installed due to a previous call.

               if Present (Full_View (Priv))
                 and then Is_Visible_Dependent (Priv)
               then

                  --  For each subtype that is swapped, we also swap the
                  --  reference to it in Private_Dependents, to allow access
                  --  to it when we swap them out in End_Package_Scope.

                  Replace_Elmt (Priv_Elmt, Full_View (Priv));
                  Exchange_Declarations (Priv);
                  Set_Is_Immediately_Visible
                    (Priv, In_Open_Scopes (Scope (Priv)));
                  Set_Is_Potentially_Use_Visible
                    (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
               end if;

               Next_Elmt (Priv_Elmt);
            end loop;
         end if;

         Next_Entity (Id);
      end loop;

      --  Next make other declarations in the private part visible as well

      Id := First_Private_Entity (P);
      while Present (Id) loop
         Install_Package_Entity (Id);
         Set_Is_Hidden (Id, False);
         Next_Entity (Id);
      end loop;

      --  Indicate that the private part is currently visible, so it can be
      --  properly reset on exit.

      Set_In_Private_Part (P);
   end Install_Private_Declarations;

   ----------------------------------
   -- Install_Visible_Declarations --
   ----------------------------------

   procedure Install_Visible_Declarations (P : Entity_Id) is
      Id          : Entity_Id;
      Last_Entity : Entity_Id;

   begin
      pragma Assert
        (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P));

      if Is_Package_Or_Generic_Package (P) then
         Last_Entity := First_Private_Entity (P);
      else
         Last_Entity := Empty;
      end if;

      Id := First_Entity (P);
      while Present (Id) and then Id /= Last_Entity loop
         Install_Package_Entity (Id);
         Next_Entity (Id);
      end loop;
   end Install_Visible_Declarations;

   --------------------------
   -- Is_Private_Base_Type --
   --------------------------

   function Is_Private_Base_Type (E : Entity_Id) return Boolean is
   begin
      return Ekind (E) = E_Private_Type
        or else Ekind (E) = E_Limited_Private_Type
        or else Ekind (E) = E_Record_Type_With_Private;
   end Is_Private_Base_Type;

   --------------------------
   -- Is_Visible_Dependent --
   --------------------------

   function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
   is
      S : constant Entity_Id := Scope (Dep);

   begin
      --  Renamings created for actual types have the visibility of the actual

      if Ekind (S) = E_Package
        and then Is_Generic_Instance (S)
        and then (Is_Generic_Actual_Type (Dep)
                   or else Is_Generic_Actual_Type (Full_View (Dep)))
      then
         return True;

      elsif not (Is_Derived_Type (Dep))
        and then Is_Derived_Type (Full_View (Dep))
      then
         --  When instantiating a package body, the scope stack is empty, so
         --  check instead whether the dependent type is defined in the same
         --  scope as the instance itself.

         return In_Open_Scopes (S)
           or else (Is_Generic_Instance (Current_Scope)
              and then Scope (Dep) = Scope (Current_Scope));
      else
         return True;
      end if;
   end Is_Visible_Dependent;

   ----------------------------
   -- May_Need_Implicit_Body --
   ----------------------------

   procedure May_Need_Implicit_Body (E : Entity_Id) is
      P     : constant Node_Id := Unit_Declaration_Node (E);
      S     : constant Node_Id := Parent (P);
      B     : Node_Id;
      Decls : List_Id;

   begin
      if not Has_Completion (E)
        and then Nkind (P) = N_Package_Declaration
        and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E))
      then
         B :=
           Make_Package_Body (Sloc (E),
             Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
               Chars => Chars (E)),
             Declarations  => New_List);

         if Nkind (S) = N_Package_Specification then
            if Present (Private_Declarations (S)) then
               Decls := Private_Declarations (S);
            else
               Decls := Visible_Declarations (S);
            end if;
         else
            Decls := Declarations (S);
         end if;

         Append (B, Decls);
         Analyze (B);
      end if;
   end May_Need_Implicit_Body;

   ----------------------
   -- New_Private_Type --
   ----------------------

   procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
   begin
      Enter_Name (Id);

      if Limited_Present (Def) then
         Set_Ekind (Id, E_Limited_Private_Type);
      else
         Set_Ekind (Id, E_Private_Type);
      end if;

      Set_Etype              (Id, Id);
      Set_Has_Delayed_Freeze (Id);
      Set_Is_First_Subtype   (Id);
      Init_Size_Align        (Id);

      Set_Is_Constrained (Id,
        No (Discriminant_Specifications (N))
          and then not Unknown_Discriminants_Present (N));

      --  Set tagged flag before processing discriminants, to catch illegal
      --  usage.

      Set_Is_Tagged_Type (Id, Tagged_Present (Def));

      Set_Discriminant_Constraint (Id, No_Elist);
      Set_Stored_Constraint (Id, No_Elist);

      if Present (Discriminant_Specifications (N)) then
         Push_Scope (Id);
         Process_Discriminants (N);
         End_Scope;

      elsif Unknown_Discriminants_Present (N) then
         Set_Has_Unknown_Discriminants (Id);
      end if;

      Set_Private_Dependents (Id, New_Elmt_List);

      if Tagged_Present (Def) then
         Set_Ekind                (Id, E_Record_Type_With_Private);
         Make_Class_Wide_Type     (Id);
         Set_Primitive_Operations (Id, New_Elmt_List);
         Set_Is_Abstract_Type     (Id, Abstract_Present (Def));
         Set_Is_Limited_Record    (Id, Limited_Present (Def));
         Set_Has_Delayed_Freeze   (Id, True);

      elsif Abstract_Present (Def) then
         Error_Msg_N ("only a tagged type can be abstract", N);
      end if;
   end New_Private_Type;

   ----------------------------
   -- Uninstall_Declarations --
   ----------------------------

   procedure Uninstall_Declarations (P : Entity_Id) is
      Decl      : constant Node_Id := Unit_Declaration_Node (P);
      Id        : Entity_Id;
      Full      : Entity_Id;
      Priv_Elmt : Elmt_Id;
      Priv_Sub  : Entity_Id;

      procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
      --  Copy to the private declaration the attributes of the full view that
      --  need to be available for the partial view also.

      function Type_In_Use (T : Entity_Id) return Boolean;
      --  Check whether type or base type appear in an active use_type clause

      ------------------------------
      -- Preserve_Full_Attributes --
      ------------------------------

      procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
         Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);

      begin
         Set_Size_Info (Priv, (Full));
         Set_RM_Size                 (Priv, RM_Size (Full));
         Set_Size_Known_At_Compile_Time
                                     (Priv, Size_Known_At_Compile_Time (Full));
         Set_Is_Volatile             (Priv, Is_Volatile                (Full));
         Set_Treat_As_Volatile       (Priv, Treat_As_Volatile          (Full));
         Set_Is_Ada_2005_Only        (Priv, Is_Ada_2005_Only           (Full));
         Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced    (Full));
         Set_Has_Pragma_Unreferenced_Objects
                                     (Priv, Has_Pragma_Unreferenced_Objects
                                                                       (Full));
         if Is_Unchecked_Union (Full) then
            Set_Is_Unchecked_Union (Base_Type (Priv));
         end if;
         --  Why is atomic not copied here ???

         if Referenced (Full) then
            Set_Referenced (Priv);
         end if;

         if Priv_Is_Base_Type then
            Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
            Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
                                                           (Base_Type (Full)));
            Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
            Set_Has_Controlled_Component (Priv, Has_Controlled_Component
                                                           (Base_Type (Full)));
         end if;

         Set_Freeze_Node (Priv, Freeze_Node (Full));

         if Is_Tagged_Type (Priv)
           and then Is_Tagged_Type (Full)
           and then not Error_Posted (Full)
         then
            if Priv_Is_Base_Type then

               --  Ada 2005 (AI-345): The full view of a type implementing an
               --  interface can be a task type.

               --    type T is new I with private;
               --  private
               --    task type T is new I with ...

               if Is_Interface (Etype (Priv))
                 and then Is_Concurrent_Type (Base_Type (Full))
               then
                  --  Protect the frontend against previous errors

                  if Present (Corresponding_Record_Type
                               (Base_Type (Full)))
                  then
                     Set_Access_Disp_Table
                       (Priv, Access_Disp_Table
                               (Corresponding_Record_Type (Base_Type (Full))));

                  --  Generic context, or previous errors

                  else
                     null;
                  end if;

               else
                  Set_Access_Disp_Table
                    (Priv, Access_Disp_Table (Base_Type (Full)));
               end if;
            end if;

            if Is_Tagged_Type (Priv) then

               --  If the type is tagged, the tag itself must be available on
               --  the partial view, for expansion purposes.

               Set_First_Entity (Priv, First_Entity (Full));

               --  If there are discriminants in the partial view, these remain
               --  visible. Otherwise only the tag itself is visible, and there
               --  are no nameable components in the partial view.

               if No (Last_Entity (Priv)) then
                  Set_Last_Entity (Priv, First_Entity (Priv));
               end if;
            end if;

            Set_Has_Discriminants (Priv, Has_Discriminants (Full));
         end if;
      end Preserve_Full_Attributes;

      -----------------
      -- Type_In_Use --
      -----------------

      function Type_In_Use (T : Entity_Id) return Boolean is
      begin
         return Scope (Base_Type (T)) = P
           and then (In_Use (T) or else In_Use (Base_Type (T)));
      end Type_In_Use;

   --  Start of processing for Uninstall_Declarations

   begin
      Id := First_Entity (P);
      while Present (Id) and then Id /= First_Private_Entity (P) loop
         if Debug_Flag_E then
            Write_Str ("unlinking visible entity ");
            Write_Int (Int (Id));
            Write_Eol;
         end if;

         --  On  exit from the package scope, we must preserve the visibility
         --  established by use clauses in the current scope. Two cases:

         --  a) If the entity is an operator, it may be a primitive operator of
         --  a type for which there is a visible use-type clause.

         --  b) for other entities, their use-visibility is determined by a
         --  visible use clause for the package itself. For a generic instance,
         --  the instantiation of the formals appears in the visible part,
         --  but the formals are private and remain so.

         if Ekind (Id) = E_Function
           and then  Is_Operator_Symbol_Name (Chars (Id))
           and then not Is_Hidden (Id)
           and then not Error_Posted (Id)
         then
            Set_Is_Potentially_Use_Visible (Id,
              In_Use (P)
              or else Type_In_Use (Etype (Id))
              or else Type_In_Use (Etype (First_Formal (Id)))
              or else (Present (Next_Formal (First_Formal (Id)))
                         and then
                           Type_In_Use
                             (Etype (Next_Formal (First_Formal (Id))))));
         else
            if In_Use (P) and then not Is_Hidden (Id) then

               --  A child unit of a use-visible package remains use-visible
               --  only if it is itself a visible child unit. Otherwise it
               --  would remain visible in other contexts where P is use-
               --  visible, because once compiled it stays in the entity list
               --  of its parent unit.

               if Is_Child_Unit (Id) then
                  Set_Is_Potentially_Use_Visible (Id,
                    Is_Visible_Child_Unit (Id));
               else
                  Set_Is_Potentially_Use_Visible (Id);
               end if;

            else
               Set_Is_Potentially_Use_Visible (Id, False);
            end if;
         end if;

         --  Local entities are not immediately visible outside of the package

         Set_Is_Immediately_Visible (Id, False);

         --  If this is a private type with a full view (for example a local
         --  subtype of a private type declared elsewhere), ensure that the
         --  full view is also removed from visibility: it may be exposed when
         --  swapping views in an instantiation.

         if Is_Type (Id)
           and then Present (Full_View (Id))
         then
            Set_Is_Immediately_Visible (Full_View (Id), False);
         end if;

         if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
            Check_Abstract_Overriding (Id);
            Check_Conventions (Id);
         end if;

         if (Ekind (Id) = E_Private_Type
               or else Ekind (Id) = E_Limited_Private_Type)
           and then No (Full_View (Id))
           and then not Is_Generic_Type (Id)
           and then not Is_Derived_Type (Id)
         then
            Error_Msg_N ("missing full declaration for private type&", Id);

         elsif Ekind (Id) = E_Record_Type_With_Private
           and then not Is_Generic_Type (Id)
           and then No (Full_View (Id))
         then
            if Nkind (Parent (Id)) = N_Private_Type_Declaration then
               Error_Msg_N ("missing full declaration for private type&", Id);
            else
               Error_Msg_N
                 ("missing full declaration for private extension", Id);
            end if;

         elsif Ekind (Id) = E_Constant
           and then No (Constant_Value (Id))
           and then No (Full_View (Id))
           and then not Is_Imported (Id)
           and then (Nkind (Parent (Id)) /= N_Object_Declaration
                      or else not No_Initialization (Parent (Id)))
         then
            if not Has_Private_Declaration (Etype (Id)) then

               --  We assume that the user did not intend a deferred
               --  constant declaration, and the expression is just missing.

               Error_Msg_N
                 ("constant declaration requires initialization expression",
                   Parent (Id));

               if Is_Limited_Type (Etype (Id)) then
                  Error_Msg_N
                    ("\if variable intended, remove CONSTANT from declaration",
                    Parent (Id));
               end if;

            else
               Error_Msg_N
                  ("missing full declaration for deferred constant (RM 7.4)",
                     Id);

               if Is_Limited_Type (Etype (Id)) then
                  Error_Msg_N
                    ("\if variable intended, remove CONSTANT from declaration",
                    Parent (Id));
               end if;
            end if;
         end if;

         Next_Entity (Id);
      end loop;

      --  If the specification was installed as the parent of a public child
      --  unit, the private declarations were not installed, and there is
      --  nothing to do.

      if not In_Private_Part (P) then
         return;
      else
         Set_In_Private_Part (P, False);
      end if;

      --  Make private entities invisible and exchange full and private
      --  declarations for private types. Id is now the first private entity
      --  in the package.

      while Present (Id) loop
         if Debug_Flag_E then
            Write_Str ("unlinking private entity ");
            Write_Int (Int (Id));
            Write_Eol;
         end if;

         if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
            Check_Abstract_Overriding (Id);
            Check_Conventions (Id);
         end if;

         Set_Is_Immediately_Visible (Id, False);

         if Is_Private_Base_Type (Id)
           and then Present (Full_View (Id))
         then
            Full := Full_View (Id);

            --  If the partial view is not declared in the visible part of the
            --  package (as is the case when it is a type derived from some
            --  other private type in the private part of the current package),
            --  no exchange takes place.

            if No (Parent (Id))
              or else List_Containing (Parent (Id))
                /= Visible_Declarations (Specification (Decl))
            then
               goto Next_Id;
            end if;

            --  The entry in the private part points to the full declaration,
            --  which is currently visible. Exchange them so only the private
            --  type declaration remains accessible, and link private and full
            --  declaration in the opposite direction. Before the actual
            --  exchange, we copy back attributes of the full view that must
            --  be available to the partial view too.

            Preserve_Full_Attributes (Id, Full);

            Set_Is_Potentially_Use_Visible (Id, In_Use (P));

            if  Is_Indefinite_Subtype (Full)
              and then not Is_Indefinite_Subtype (Id)
            then
               Error_Msg_N
                 ("full view of type must be definite subtype", Full);
            end if;

            Priv_Elmt := First_Elmt (Private_Dependents (Id));

            --  Swap out the subtypes and derived types of Id that were
            --  compiled in this scope, or installed previously by
            --  Install_Private_Declarations.

            --  Before we do the swap, we verify the presence of the Full_View
            --  field which may be empty due to a swap by a previous call to
            --  End_Package_Scope (e.g. from the freezing mechanism).

            while Present (Priv_Elmt) loop
               Priv_Sub := Node (Priv_Elmt);

               if Present (Full_View (Priv_Sub)) then

                  if Scope (Priv_Sub) = P
                     or else not In_Open_Scopes (Scope (Priv_Sub))
                  then
                     Set_Is_Immediately_Visible (Priv_Sub, False);
                  end if;

                  if Is_Visible_Dependent (Priv_Sub) then
                     Preserve_Full_Attributes
                       (Priv_Sub, Full_View (Priv_Sub));
                     Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
                     Exchange_Declarations (Priv_Sub);
                  end if;
               end if;

               Next_Elmt (Priv_Elmt);
            end loop;

            --  Now restore the type itself to its private view

            Exchange_Declarations (Id);

            --  If we have installed an underlying full view for a type derived
            --  from a private type in a child unit, restore the proper views
            --  of private and full view. See corresponding code in
            --  Install_Private_Declarations.

            --  After the exchange, Full denotes the private type in the
            --  visible part of the package.

            if Is_Private_Base_Type (Full)
              and then Present (Full_View (Full))
              and then Present (Underlying_Full_View (Full))
              and then In_Package_Body (Current_Scope)
            then
               Set_Full_View (Full, Underlying_Full_View (Full));
               Set_Underlying_Full_View (Full, Empty);
            end if;

         elsif Ekind (Id) = E_Incomplete_Type
           and then Comes_From_Source (Id)
           and then No (Full_View (Id))
         then
            --  Mark Taft amendment types. Verify that there are no primitive
            --  operations declared for the type (3.10.1 (9)).

            Set_Has_Completion_In_Body (Id);

            declare
               Elmt : Elmt_Id;
               Subp : Entity_Id;

            begin
               Elmt := First_Elmt (Private_Dependents (Id));
               while Present (Elmt) loop
                  Subp := Node (Elmt);

                  if Is_Overloadable (Subp) then
                     Error_Msg_NE
                       ("type& must be completed in the private part",
                         Parent (Subp), Id);

                  --  The return type of an access_to_function cannot be a
                  --  Taft-amendment type.

                  elsif Ekind (Subp) = E_Subprogram_Type then
                     if Etype (Subp) = Id
                       or else
                         (Is_Class_Wide_Type (Etype (Subp))
                            and then Etype (Etype (Subp)) = Id)
                     then
                        Error_Msg_NE
                          ("type& must be completed in the private part",
                             Associated_Node_For_Itype (Subp), Id);
                     end if;
                  end if;

                  Next_Elmt (Elmt);
               end loop;
            end;

         elsif not Is_Child_Unit (Id)
           and then (not Is_Private_Type (Id)
                      or else No (Full_View (Id)))
         then
            Set_Is_Hidden (Id);
            Set_Is_Potentially_Use_Visible (Id, False);
         end if;

         <<Next_Id>>
            Next_Entity (Id);
      end loop;
   end Uninstall_Declarations;

   ------------------------
   -- Unit_Requires_Body --
   ------------------------

   function Unit_Requires_Body (P : Entity_Id) return Boolean is
      E : Entity_Id;

   begin
      --  Imported entity never requires body. Right now, only subprograms can
      --  be imported, but perhaps in the future we will allow import of
      --  packages.

      if Is_Imported (P) then
         return False;

      --  Body required if library package with pragma Elaborate_Body

      elsif Has_Pragma_Elaborate_Body (P) then
         return True;

      --  Body required if subprogram

      elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
         return True;

      --  Treat a block as requiring a body

      elsif Ekind (P) = E_Block then
         return True;

      elsif Ekind (P) = E_Package
        and then Nkind (Parent (P)) = N_Package_Specification
        and then Present (Generic_Parent (Parent (P)))
      then
         declare
            G_P : constant Entity_Id := Generic_Parent (Parent (P));
         begin
            if Has_Pragma_Elaborate_Body (G_P) then
               return True;
            end if;
         end;
      end if;

      --  Otherwise search entity chain for entity requiring completion

      E := First_Entity (P);
      while Present (E) loop

         --  Always ignore child units. Child units get added to the entity
         --  list of a parent unit, but are not original entities of the
         --  parent, and so do not affect whether the parent needs a body.

         if Is_Child_Unit (E) then
            null;

         --  Ignore formal packages and their renamings

         elsif Ekind (E) = E_Package
           and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
                                                N_Formal_Package_Declaration
         then
            null;

         --  Otherwise test to see if entity requires a completion.
         --  Note that subprogram entities whose declaration does not come
         --  from source are ignored here on the basis that we assume the
         --  expander will provide an implicit completion at some point.

         elsif (Is_Overloadable (E)
               and then Ekind (E) /= E_Enumeration_Literal
               and then Ekind (E) /= E_Operator
               and then not Is_Abstract_Subprogram (E)
               and then not Has_Completion (E)
               and then Comes_From_Source (Parent (E)))

           or else
             (Ekind (E) = E_Package
               and then E /= P
               and then not Has_Completion (E)
               and then Unit_Requires_Body (E))

           or else
             (Ekind (E) = E_Incomplete_Type and then No (Full_View (E)))

           or else
            ((Ekind (E) = E_Task_Type or else
              Ekind (E) = E_Protected_Type)
               and then not Has_Completion (E))

           or else
             (Ekind (E) = E_Generic_Package and then E /= P
               and then not Has_Completion (E)
               and then Unit_Requires_Body (E))

           or else
             (Is_Generic_Subprogram (E)
               and then not Has_Completion (E))

         then
            return True;

         --  Entity that does not require completion

         else
            null;
         end if;

         Next_Entity (E);
      end loop;

      return False;
   end Unit_Requires_Body;

end Sem_Ch7;