summaryrefslogtreecommitdiff
path: root/gcc/ada/a-except.adb
blob: 30393145309d40c323f2410ce4628b12a2502434 (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
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       A D A . E X C E P T I O N S                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2002 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 2,  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 COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

pragma Polling (Off);
--  We must turn polling off for this unit, because otherwise we get
--  elaboration circularities with System.Exception_Tables.

with Ada.Unchecked_Deallocation;

with GNAT.Heap_Sort_A;        use GNAT.Heap_Sort_A;

with System;                  use System;
with System.Exception_Table;  use System.Exception_Table;
with System.Exceptions;       use System.Exceptions;
with System.Standard_Library; use System.Standard_Library;
with System.Storage_Elements; use System.Storage_Elements;
with System.Soft_Links;       use System.Soft_Links;
with System.Machine_State_Operations; use System.Machine_State_Operations;
with System.Traceback;

with Unchecked_Conversion;

package body Ada.Exceptions is

   procedure builtin_longjmp (buffer : Address; Flag : Integer);
   pragma No_Return (builtin_longjmp);
   pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");

   pragma Suppress (All_Checks);
   --  We definitely do not want exceptions occurring within this unit, or
   --  we are in big trouble. If an exceptional situation does occur, better
   --  that it not be raised, since raising it can cause confusing chaos.

   type Subprogram_Descriptor_List_Ptr is
     access all Subprogram_Descriptor_List;

   Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;
   --  This location is initialized by Register_Exceptions to point to a
   --  list of pointers to procedure descriptors, sorted into ascending
   --  order of PC addresses.
   --
   --  Note that SDP_Table_Build is called *before* this unit (or any
   --  other unit) is elaborated. That's important, because exceptions can
   --  and do occur during elaboration of units, and must be handled during
   --  elaboration. This means that we are counting on the fact that the
   --  initialization of Subprogram_Descriptors to null is done by the
   --  load process and NOT by an explicit assignment during elaboration.

   Num_Subprogram_Descriptors : Natural;
   --  Number of subprogram descriptors, the useful descriptors are stored
   --  in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There
   --  can be unused entries at the end of the array due to elimination of
   --  duplicated entries (which can arise from use of pragma Import).

   Exception_Tracebacks : Integer;
   pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
   --  Boolean indicating whether tracebacks should be stored in exception
   --  occurrences.

   Zero_Cost_Exceptions : Integer;
   pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
   --  Boolean indicating if we are handling exceptions using a zero cost
   --  mechanism.
   --
   --  ??? We currently have two alternatives for this scheme : one using
   --  front-end tables and one using back-end tables. The former is known to
   --  only work for GNAT3 and the latter is known to only work for GNAT5.
   --  Both are present in this implementation and it would be good to have
   --  separate bodies at some point.
   --
   --  Note that although we currently do not support it, the GCC3 back-end
   --  tables are also potentially useable for setjmp/longjmp processing.

   Nline : constant String := String' (1 => ASCII.LF);
   --  Convenient shortcut

   ------------------------------------------------
   -- Entities to interface with the GCC runtime --
   ------------------------------------------------

   --  These come from "C++ ABI for Itanium : Exception handling", which is
   --  the reference for GCC. They are used only when we are relying on
   --  back-end tables for exception propagation, which in turn is currenly
   --  only the case for Zero_Cost_Exceptions in GNAT5.

   --  Return codes from the GCC runtime functions used to propagate
   --  an exception.

   type Unwind_Reason_Code is
     (URC_NO_REASON,
      URC_FOREIGN_EXCEPTION_CAUGHT,
      URC_PHASE2_ERROR,
      URC_PHASE1_ERROR,
      URC_NORMAL_STOP,
      URC_END_OF_STACK,
      URC_HANDLER_FOUND,
      URC_INSTALL_CONTEXT,
      URC_CONTINUE_UNWIND);

   --  ??? pragma Unreferenced is unknown until 3.15, so we need to disable
   --  warnings around it to fix the bootstrap path.

   pragma Warnings (Off);
   pragma Unreferenced
     (URC_NO_REASON,
      URC_FOREIGN_EXCEPTION_CAUGHT,
      URC_PHASE2_ERROR,
      URC_PHASE1_ERROR,
      URC_NORMAL_STOP,
      URC_END_OF_STACK,
      URC_HANDLER_FOUND,
      URC_INSTALL_CONTEXT,
      URC_CONTINUE_UNWIND);
   pragma Warnings (On);

   pragma Convention (C, Unwind_Reason_Code);

   --  Mandatory common header for any exception object handled by the
   --  GCC unwinding runtime.

   subtype Exception_Class is String (1 .. 8);

   GNAT_Exception_Class : constant Exception_Class
     := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL;

   type Unwind_Exception is record
      Class    : Exception_Class := GNAT_Exception_Class;
      Cleanup  : System.Address  := System.Null_Address;
      Private1 : Integer;
      Private2 : Integer;
   end record;

   pragma Convention (C, Unwind_Exception);

   for Unwind_Exception'Alignment use Standard'Maximum_Alignment;

   --  A GNAT exception object to be dealt with by the personality routine
   --  called by the GCC unwinding runtime. This structure shall match the
   --  one in raise.c and is currently experimental as it might be merged
   --  with the GNAT runtime definition some day.

   type GNAT_GCC_Exception is record
      Header : Unwind_Exception;
      --  Exception header first, as required by the ABI.

      Id : Exception_Id;
      --  Usual Exception identifier

      Handled_By_Others : Boolean;
      --  Is this exception handled by "when others" ?

      Has_Cleanup : Boolean;
      --  Did we see any at-end handler while walking up the stack
      --  searching for a handler ? This is used to determine if we
      --  start the propagation again after having tried once without
      --  finding a true handler for the exception.

      Select_Cleanups : Boolean;
      --  Do we consider at-end handlers as legitimate handlers for the
      --  exception ? This is used to control the propagation process
      --  as described in Raise_Current_Excep.
   end record;

   pragma Convention (C, GNAT_GCC_Exception);

   --  GCC runtime functions used

   function Unwind_RaiseException
     (E    : access GNAT_GCC_Exception)
      return Unwind_Reason_Code;
   pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");

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

   --  Note: the exported subprograms in this package body are called directly
   --  from C clients using the given external name, even though they are not
   --  technically visible in the Ada sense.

   procedure AAA;
   --  Mark start of procedures in this unit

   procedure ZZZ;
   --  Mark end of procedures in this package

   function Address_Image (A : System.Address) return String;
   --  Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
   --  or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
   --  in lower case.

   procedure Call_Chain (Excep : EOA);
   --  Store up to Max_Tracebacks in Excep, corresponding to the current
   --  call chain.

   procedure Free
     is new Ada.Unchecked_Deallocation
       (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr);

   procedure Process_Raise_Exception
     (E                   : Exception_Id;
      From_Signal_Handler : Boolean);
   pragma Inline (Process_Raise_Exception);
   pragma No_Return (Process_Raise_Exception);
   --  This is the lowest level raise routine. It raises the exception
   --  referenced by Current_Excep.all in the TSD, without deferring abort
   --  (the caller must ensure that abort is deferred on entry).
   --
   --  This is actually the common implementation for Raise_Current_Excep and
   --  Raise_From_Signal_Handler, with a couple of operations inhibited when
   --  called from the latter. The origin of the call is indicated by the
   --  From_Signal_Handler argument.
   --
   --  The Inline pragma is there for efficiency reasons.

   procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State);
   pragma No_Return (Propagate_Exception_With_FE_Support);
   --  This procedure propagates the exception represented by the occurrence
   --  referenced by Current_Excep in the TSD for the current task. M is the
   --  initial machine state, representing the site of the exception raise
   --  operation.
   --
   --  The procedure searches the front end exception tables for an applicable
   --  handler, calling Pop_Frame as needed. If and when it locates an
   --  applicable handler, Enter_Handler is called to actually enter this
   --  handler. If the search is unable to locate an applicable handler,
   --  execution is terminated by calling Unhandled_Exception_Terminate.

   procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State);
   pragma No_Return (Propagate_Exception_With_GCC_Support);
   --  This procedure propagates the exception represented by the occurrence
   --  referenced by Current_Excep in the TSD for the current task. M is the
   --  initial machine state, representing the site of the exception raise
   --  operation. It is currently not used and is there for the purpose of
   --  interface consistency against Propagate_Exception_With_FE_Support.
   --
   --  The procedure builds an object suitable for the libgcc processing and
   --  calls Unwind_RaiseException to actually throw, taking care of handling
   --  the two phase scheme it implements.

   procedure Raise_Current_Excep (E : Exception_Id);
   pragma No_Return (Raise_Current_Excep);
   pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
   --  This is a simple wrapper to Process_Raise_Exception setting the
   --  From_Signal_Handler argument to False.
   --
   --  This external name for Raise_Current_Excep is historical, and probably
   --  should be changed but for now we keep it, because gdb and gigi know
   --  about it.

   procedure Raise_Exception_No_Defer
      (E : Exception_Id; Message : String := "");
   pragma Export (Ada, Raise_Exception_No_Defer,
     "ada__exceptions__raise_exception_no_defer");
   pragma No_Return (Raise_Exception_No_Defer);
   --  Similar to Raise_Exception, but with no abort deferral

   procedure Raise_With_Msg (E : Exception_Id);
   pragma No_Return (Raise_With_Msg);
   pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
   --  Raises an exception with given exception id value. A message
   --  is associated with the raise, and has already been stored in the
   --  exception occurrence referenced by the Current_Excep in the TSD.
   --  Abort is deferred before the raise call.

   procedure Raise_With_Location
     (E : Exception_Id;
      F : Big_String_Ptr;
      L : Integer);
   pragma No_Return (Raise_With_Location);
   --  Raise an exception with given exception id value. A filename and line
   --  number is associated with the raise and is stored in the exception
   --  occurrence.

   procedure Raise_With_Location_And_Msg
     (E : Exception_Id;
      F : Big_String_Ptr;
      L : Integer;
      M : Big_String_Ptr);
   pragma No_Return (Raise_With_Location_And_Msg);
   --  Raise an exception with given exception id value. A filename and line
   --  number is associated with the raise and is stored in the exception
   --  occurrence and in addition a string message M is appended to this.

   procedure Raise_Constraint_Error
     (File : Big_String_Ptr;
      Line : Integer);
   pragma No_Return (Raise_Constraint_Error);
   pragma Export
     (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
   --  Raise constraint error with file:line information

   procedure Raise_Constraint_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr);
   pragma No_Return (Raise_Constraint_Error_Msg);
   pragma Export
     (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
   --  Raise constraint error with file:line + msg information

   procedure Raise_Program_Error
     (File : Big_String_Ptr;
      Line : Integer);
   pragma No_Return (Raise_Program_Error);
   pragma Export
     (C, Raise_Program_Error, "__gnat_raise_program_error");
   --  Raise program error with file:line information

   procedure Raise_Program_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr);
   pragma No_Return (Raise_Program_Error_Msg);
   pragma Export
     (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
   --  Raise program error with file:line + msg information

   procedure Raise_Storage_Error
     (File : Big_String_Ptr;
      Line : Integer);
   pragma No_Return (Raise_Storage_Error);
   pragma Export
     (C, Raise_Storage_Error, "__gnat_raise_storage_error");
   --  Raise storage error with file:line information

   procedure Raise_Storage_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr);
   pragma No_Return (Raise_Storage_Error_Msg);
   pragma Export
     (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
   --  Raise storage error with file:line + reason msg information

   --  The exception raising process and the automatic tracing mechanism rely
   --  on some careful use of flags attached to the exception occurrence. The
   --  graph below illustrates the relations between the Raise_ subprograms
   --  and identifies the points where basic flags such as Exception_Raised
   --  are initialized.
   --
   --  (i) signs indicate the flags initialization points. R stands for Raise,
   --  W for With, and E for Exception.
   --
   --                   R_No_Msg    R_E   R_Pe  R_Ce  R_Se
   --                       |        |     |     |     |
   --                       +--+  +--+     +---+ | +---+
   --                          |  |            | | |
   --     R_E_No_Defer(i)    R_W_Msg(i)       R_W_Loc      R_W_C_Msg
   --           |               |              |   |        |    |
   --           +------------+  |  +-----------+   +--+  +--+    |
   --                        |  |  |                  |  |       |
   --                        |  |  |              Set_E_C_Msg(i) |
   --                        |  |  |                             |
   --                        |  |  |  +--------------------------+
   --                        |  |  |  |
   --                   Raise_Current_Excep

   procedure Reraise;
   pragma No_Return (Reraise);
   pragma Export (C, Reraise, "__gnat_reraise");
   --  Reraises the exception referenced by the Current_Excep field of
   --  the TSD (all fields of this exception occurrence are set). Abort
   --  is deferred before the reraise operation.

   function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean;
   --  Used in call to sort SDP table (SDP_Table_Build), compares two elements

   procedure SDP_Table_Sort_Move (From : Natural; To : Natural);
   --  Used in call to sort SDP table (SDP_Table_Build), moves one element

   procedure Set_Exception_C_Msg
     (Id   : Exception_Id;
      Msg1 : Big_String_Ptr;
      Line : Integer        := 0;
      Msg2 : Big_String_Ptr := null);
   --  This routine is called to setup the exception referenced by the
   --  Current_Excep field in the TSD to contain the indicated Id value
   --  and message. Msg1 is a null terminated string which is generated
   --  as the exception message. If line is non-zero, then a colon and
   --  the decimal representation of this integer is appended to the
   --  message. When Msg2 is non-null, a space and this additional null
   --  terminated string is added to the message.

   procedure To_Stderr (S : String);
   pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
   --  Little routine to output string to stderr that is also used
   --  in the tasking run time.

   procedure Unhandled_Exception_Terminate;
   pragma No_Return (Unhandled_Exception_Terminate);
   --  This procedure is called to terminate execution following an unhandled
   --  exception. The exception information, including traceback if available
   --  is output, and execution is then terminated. Note that at the point
   --  where this routine is called, the stack has typically been destroyed

   ---------------------------------
   -- Debugger Interface Routines --
   ---------------------------------

   --  The routines here are null routines that normally have no effect.
   --  they are provided for the debugger to place breakpoints on their
   --  entry points to get control on an exception.

   procedure Notify_Exception
     (Id        : Exception_Id;
      Handler   : Code_Loc;
      Is_Others : Boolean);
   pragma Export (C, Notify_Exception, "__gnat_notify_exception");
   --  This routine is called whenever an exception is signalled. The Id
   --  parameter is the Exception_Id of the exception being raised. The
   --  second parameter Handler is Null_Loc if the exception is unhandled,
   --  and is otherwise the entry point of the handler that will handle
   --  the exception. Is_Others is True if the handler is an others handler
   --  and False otherwise. In the unhandled exception case, if possible
   --  (and certainly if zero cost exception handling is active), the
   --  stack is still intact when this procedure is called. Note that this
   --  routine is entered before any finalization handlers are entered if
   --  the exception is unhandled by a "real" exception handler.

   procedure Unhandled_Exception;
   pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
   --  This routine is called in addition to Notify_Exception in the
   --  unhandled exception case. The fact that there are two routines
   --  which are somewhat redundant is historical. Notify_Exception
   --  certainly is complete enough, but GDB still uses this routine.

   -----------------------------
   -- Run-Time Check Routines --
   -----------------------------

   --  These routines are called from the runtime to raise a specific
   --  exception with a reason message attached. The parameters are
   --  the file name and line number in each case. The names are keyed
   --  to the codes defined in Types.ads and a-types.h (for example,
   --  the name Rcheck_05 refers to the Reason whose Pos code is 5).

   procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer);
   procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer);

   pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
   pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
   pragma Export (C, Rcheck_02, "__gnat_rcheck_02");
   pragma Export (C, Rcheck_03, "__gnat_rcheck_03");
   pragma Export (C, Rcheck_04, "__gnat_rcheck_04");
   pragma Export (C, Rcheck_05, "__gnat_rcheck_05");
   pragma Export (C, Rcheck_06, "__gnat_rcheck_06");
   pragma Export (C, Rcheck_07, "__gnat_rcheck_07");
   pragma Export (C, Rcheck_08, "__gnat_rcheck_08");
   pragma Export (C, Rcheck_09, "__gnat_rcheck_09");
   pragma Export (C, Rcheck_10, "__gnat_rcheck_10");
   pragma Export (C, Rcheck_11, "__gnat_rcheck_11");
   pragma Export (C, Rcheck_12, "__gnat_rcheck_12");
   pragma Export (C, Rcheck_13, "__gnat_rcheck_13");
   pragma Export (C, Rcheck_14, "__gnat_rcheck_14");
   pragma Export (C, Rcheck_15, "__gnat_rcheck_15");
   pragma Export (C, Rcheck_16, "__gnat_rcheck_16");
   pragma Export (C, Rcheck_17, "__gnat_rcheck_17");
   pragma Export (C, Rcheck_18, "__gnat_rcheck_18");
   pragma Export (C, Rcheck_19, "__gnat_rcheck_19");
   pragma Export (C, Rcheck_20, "__gnat_rcheck_20");
   pragma Export (C, Rcheck_21, "__gnat_rcheck_21");
   pragma Export (C, Rcheck_22, "__gnat_rcheck_22");
   pragma Export (C, Rcheck_23, "__gnat_rcheck_23");
   pragma Export (C, Rcheck_24, "__gnat_rcheck_24");
   pragma Export (C, Rcheck_25, "__gnat_rcheck_25");
   pragma Export (C, Rcheck_26, "__gnat_rcheck_26");
   pragma Export (C, Rcheck_27, "__gnat_rcheck_27");
   pragma Export (C, Rcheck_28, "__gnat_rcheck_28");

   ---------------------------------------------
   -- Reason Strings for Run-Time Check Calls --
   ---------------------------------------------

   --  These strings are null-terminated and are used by Rcheck_nn. The
   --  strings correspond to the definitions for Types.RT_Exception_Code.

   use ASCII;

   Rmsg_00 : constant String := "access check failed"              & NUL;
   Rmsg_01 : constant String := "access parameter is null"         & NUL;
   Rmsg_02 : constant String := "discriminant check failed"        & NUL;
   Rmsg_03 : constant String := "divide by zero"                   & NUL;
   Rmsg_04 : constant String := "explicit raise"                   & NUL;
   Rmsg_05 : constant String := "index check failed"               & NUL;
   Rmsg_06 : constant String := "invalid data"                     & NUL;
   Rmsg_07 : constant String := "length check failed"              & NUL;
   Rmsg_08 : constant String := "overflow check failed"            & NUL;
   Rmsg_09 : constant String := "partition check failed"           & NUL;
   Rmsg_10 : constant String := "range check failed"               & NUL;
   Rmsg_11 : constant String := "tag check failed"                 & NUL;
   Rmsg_12 : constant String := "access before elaboration"        & NUL;
   Rmsg_13 : constant String := "accessibility check failed"       & NUL;
   Rmsg_14 : constant String := "all guards closed"                & NUL;
   Rmsg_15 : constant String := "duplicated entry address"         & NUL;
   Rmsg_16 : constant String := "explicit raise"                   & NUL;
   Rmsg_17 : constant String := "finalize raised exception"        & NUL;
   Rmsg_18 : constant String := "invalid data"                     & NUL;
   Rmsg_19 : constant String := "misaligned address value"         & NUL;
   Rmsg_20 : constant String := "missing return"                   & NUL;
   Rmsg_21 : constant String := "potentially blocking operation"   & NUL;
   Rmsg_22 : constant String := "stubbed subprogram called"        & NUL;
   Rmsg_23 : constant String := "unchecked union restriction"      & NUL;
   Rmsg_24 : constant String := "empty storage pool"               & NUL;
   Rmsg_25 : constant String := "explicit raise"                   & NUL;
   Rmsg_26 : constant String := "infinite recursion"               & NUL;
   Rmsg_27 : constant String := "object too large"                 & NUL;
   Rmsg_28 : constant String := "restriction violation"            & NUL;

   --------------------------------------
   -- Calls to Run-Time Check Routines --
   --------------------------------------

   procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address));
   end Rcheck_00;

   procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address));
   end Rcheck_01;

   procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address));
   end Rcheck_02;

   procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address));
   end Rcheck_03;

   procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address));
   end Rcheck_04;

   procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address));
   end Rcheck_05;

   procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address));
   end Rcheck_06;

   procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address));
   end Rcheck_07;

   procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address));
   end Rcheck_08;

   procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address));
   end Rcheck_09;

   procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address));
   end Rcheck_10;

   procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address));
   end Rcheck_11;

   procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address));
   end Rcheck_12;

   procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address));
   end Rcheck_13;

   procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address));
   end Rcheck_14;

   procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address));
   end Rcheck_15;

   procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address));
   end Rcheck_16;

   procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address));
   end Rcheck_17;

   procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address));
   end Rcheck_18;

   procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address));
   end Rcheck_19;

   procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address));
   end Rcheck_20;

   procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address));
   end Rcheck_21;

   procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address));
   end Rcheck_22;

   procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address));
   end Rcheck_23;

   procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address));
   end Rcheck_24;

   procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address));
   end Rcheck_25;

   procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address));
   end Rcheck_26;

   procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address));
   end Rcheck_27;

   procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is
   begin
      Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address));
   end Rcheck_28;

   ---------------------------------------
   -- Exception backtracing subprograms --
   ---------------------------------------

   --  What is automatically output when exception tracing is on basically
   --  corresponds to the usual exception information, but with the call
   --  chain backtrace possibly tailored by a backtrace decorator. Modifying
   --  Exception_Information itself is not a good idea because the decorated
   --  output is completely out of control and would break all our code
   --  related to the streaming of exceptions.
   --
   --  We then provide an alternative function to Exception_Information to
   --  compute the possibly tailored output, which is equivalent if no
   --  decorator is currently set :

   function Tailored_Exception_Information
     (X    : Exception_Occurrence)
      return String;
   --  Exception information to be output in the case of automatic tracing
   --  requested through GNAT.Exception_Traces.
   --
   --  This is the same as Exception_Information if no backtrace decorator
   --  is currently in place. Otherwise, this is Exception_Information with
   --  the call chain raw addresses replaced by the result of a call to the
   --  current decorator provided with the call chain addresses.

   pragma Export
     (Ada, Tailored_Exception_Information,
      "__gnat_tailored_exception_information");
   --  This function is used within this package but also from within
   --  System.Tasking.Stages.
   --
   --  The output of Exception_Information and Tailored_Exception_Information
   --  share a common part which was formerly built using local procedures
   --  within Exception_Information. These procedures have been extracted from
   --  their original place to be available to Tailored_Exception_Information
   --  also.
   --
   --  Each of these procedures appends some input to an information string
   --  currently being built. The Ptr argument represents the last position
   --  in this string at which a character has been written.

   procedure Append_Info_Nat
     (N    : Natural;
      Info : in out String;
      Ptr  : in out Natural);
   --  Append the image of N at the end of the provided information string

   procedure Append_Info_NL
     (Info : in out String;
      Ptr  : in out Natural);
   --  Append a LF at the end of the provided information string

   procedure Append_Info_String
     (S    : String;
      Info : in out String;
      Ptr  : in out Natural);
   --  Append a string at the end of the provided information string

   --  To build Exception_Information and Tailored_Exception_Information,
   --  we then use three intermediate functions :

   function Basic_Exception_Information
     (X    : Exception_Occurrence)
      return String;
   --  Returns the basic exception information string associated with a
   --  given exception occurrence. This is the common part shared by both
   --  Exception_Information and Tailored_Exception_Infomation.

   function Basic_Exception_Traceback
     (X    : Exception_Occurrence)
      return String;
   --  Returns an image of the complete call chain associated with an
   --  exception occurrence in its most basic form, that is as a raw sequence
   --  of hexadecimal binary addresses.

   function Tailored_Exception_Traceback
     (X    : Exception_Occurrence)
      return String;
   --  Returns an image of the complete call chain associated with an
   --  exception occurrence, either in its basic form if no decorator is
   --  in place, or as formatted by the decorator otherwise.

   --  The overall organization of the exception information related code
   --  is summarized below :
   --
   --           Exception_Information
   --                    |
   --            +-------+--------+
   --            |                |
   --     Basic_Exc_Info & Basic_Exc_Tback
   --
   --
   --       Tailored_Exception_Information
   --                    |
   --         +----------+----------+
   --         |                     |
   --  Basic_Exc_Info    &  Tailored_Exc_Tback
   --                               |
   --                   +-----------+------------+
   --                   |                        |
   --            Basic_Exc_Tback    Or    Tback_Decorator
   --          if no decorator set           otherwise

   ----------------------------------------------
   -- Run-Time Exception Notification Routines --
   ----------------------------------------------

   --  The notification routines described above are low level "handles" for
   --  the debugger but what needs to be done at the notification points
   --  always involves more than just calling one of these routines. The
   --  routines below provide a common run-time interface for this purpose,
   --  with variations depending on the handled/not handled status of the
   --  occurrence. They are exported to be usable by the Ada exception
   --  handling personality routine when the GCC 3 mechanism is used.

   procedure Notify_Handled_Exception
     (Handler    : Code_Loc;
      Is_Others  : Boolean;
      Low_Notify : Boolean);
   pragma Export (C, Notify_Handled_Exception,
      "__gnat_notify_handled_exception");
   --  Routine to call when a handled occurrence is about to be propagated.
   --  Low_Notify might be set to false to skip the low level debugger
   --  notification, which is useful when the information it requires is
   --  not available, like in the SJLJ case.

   procedure Notify_Unhandled_Exception (Id : Exception_Id);
   pragma Export (C, Notify_Unhandled_Exception,
     "__gnat_notify_unhandled_exception");
   --  Routine to call when an unhandled occurrence is about to be propagated.

   --------------------------------
   -- Import Run-Time C Routines --
   --------------------------------

   --  The purpose of the following pragma Imports is to ensure that we
   --  generate appropriate subprogram descriptors for all C routines in
   --  the standard GNAT library that can raise exceptions. This ensures
   --  that the exception propagation can properly find these routines

   pragma Warnings (Off);        -- so old compiler does not complain
   pragma Propagate_Exceptions;

   procedure Unhandled_Terminate;
   pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");

   -----------------------
   -- Polling Interface --
   -----------------------

   type Unsigned is mod 2 ** 32;

   Counter : Unsigned := 0;
   --  This counter is provided for convenience. It can be used in Poll to
   --  perform periodic but not systematic operations.

   procedure Poll is separate;
   --  The actual polling routine is separate, so that it can easily
   --  be replaced with a target dependent version.

   ---------
   -- AAA --
   ---------

   --  This dummy procedure gives us the start of the PC range for addresses
   --  within the exception unit itself. We hope that gigi/gcc keep all the
   --  procedures in their original order!

   procedure AAA is
   begin
      null;
   end AAA;

   -------------------
   -- Address_Image --
   -------------------

   function Address_Image (A : Address) return String is
      S : String (1 .. 18);
      P : Natural;
      N : Integer_Address;

      H : constant array (Integer range 0 .. 15) of Character :=
                                                         "0123456789abcdef";
   begin
      P := S'Last;
      N := To_Integer (A);
      while N /= 0 loop
         S (P) := H (Integer (N mod 16));
         P := P - 1;
         N := N / 16;
      end loop;

      S (P - 1) := '0';
      S (P) := 'x';
      return S (P - 1 .. S'Last);
   end Address_Image;

   ---------------------
   -- Append_Info_Nat --
   ---------------------

   procedure Append_Info_Nat
     (N    : Natural;
      Info : in out String;
      Ptr  : in out Natural)
   is
   begin
      if N > 9 then
         Append_Info_Nat (N / 10, Info, Ptr);
      end if;

      Ptr := Ptr + 1;
      Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10);
   end Append_Info_Nat;

   --------------------
   -- Append_Info_NL --
   --------------------

   procedure Append_Info_NL
     (Info : in out String;
      Ptr  : in out Natural)
   is
   begin
      Ptr := Ptr + 1;
      Info (Ptr) := ASCII.LF;
   end Append_Info_NL;

   ------------------------
   -- Append_Info_String --
   ------------------------

   procedure Append_Info_String
     (S    : String;
      Info : in out String;
      Ptr  : in out Natural)
   is
   begin
      Info (Ptr + 1 .. Ptr + S'Length) := S;
      Ptr := Ptr + S'Length;
   end Append_Info_String;

   ---------------------------------
   -- Basic_Exception_Information --
   ---------------------------------

   function Basic_Exception_Information
     (X    : Exception_Occurrence)
      return String
   is
      Name : constant String  := Exception_Name (X);
      Msg  : constant String  := Exception_Message (X);
      --  Exception name and message that are going to be included in the
      --  information to return, if not empty.

      Name_Len : constant Natural := Name'Length;
      Msg_Len  : constant Natural := Msg'Length;
      --  Length of these strings, useful to compute the size of the string
      --  we have to allocate for the complete result as well as in the body
      --  of this procedure.

      Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len;
      --  Maximum length of the information string we will build, with :
      --
      --  50 =    16 + 2   for the text associated with the name
      --        +  9 + 2   for the text associated with the message
      --        +  5 + 2   for the text associated with the pid
      --        + 14       for the text image of the pid itself and a margin.
      --
      --  This is indeed a maximum since some data may not appear at all if
      --  not relevant. For example, nothing related to the exception message
      --  will be there if this message is empty.
      --
      --  WARNING : Do not forget to update these numbers if anything
      --  involved in the computation changes.

      Info : String (1 .. Info_Maxlen);
      --  Information string we are going to build, containing the common
      --  part shared by Exc_Info and Tailored_Exc_Info.

      Ptr  : Natural := 0;

   begin
      --  Output exception name and message except for _ABORT_SIGNAL, where
      --  these two lines are omitted (see discussion above).

      if Name (1) /= '_' then
         Append_Info_String ("Exception name: ", Info, Ptr);
         Append_Info_String (Name, Info, Ptr);
         Append_Info_NL (Info, Ptr);

         if Msg_Len /= 0 then
            Append_Info_String ("Message: ", Info, Ptr);
            Append_Info_String (Msg, Info, Ptr);
            Append_Info_NL (Info, Ptr);
         end if;
      end if;

      --  Output PID line if non-zero

      if X.Pid /= 0 then
         Append_Info_String ("PID: ", Info, Ptr);
         Append_Info_Nat (X.Pid, Info, Ptr);
         Append_Info_NL (Info, Ptr);
      end if;

      return Info (1 .. Ptr);
   end Basic_Exception_Information;

   -------------------------------
   -- Basic_Exception_Traceback --
   -------------------------------

   function Basic_Exception_Traceback
     (X    : Exception_Occurrence)
      return String
   is
      Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
      --  Maximum length of the information string we are building, with :
      --  33 = 31 + 4      for the text before and after the traceback, and
      --  19 =  2 + 16 + 1 for each address ("0x" + HHHH + " ")
      --
      --  WARNING : Do not forget to update these numbers if anything
      --  involved in the computation changes.

      Info : String (1 .. Info_Maxlen);
      --  Information string we are going to build, containing an image
      --  of the call chain associated with the exception occurrence in its
      --  most basic form, that is as a sequence of binary addresses.

      Ptr  : Natural := 0;

   begin
      if X.Num_Tracebacks > 0 then
         Append_Info_String ("Call stack traceback locations:", Info, Ptr);
         Append_Info_NL (Info, Ptr);

         for J in 1 .. X.Num_Tracebacks loop
            Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr);
            exit when J = X.Num_Tracebacks;
            Append_Info_String (" ", Info, Ptr);
         end loop;

         Append_Info_NL (Info, Ptr);
      end if;

      return Info (1 .. Ptr);
   end Basic_Exception_Traceback;

   -----------------
   -- Break_Start --
   -----------------

   procedure Break_Start is
   begin
      null;
   end Break_Start;

   ----------------
   -- Call_Chain --
   ----------------

   procedure Call_Chain (Excep : EOA) is
   begin
      if Excep.Num_Tracebacks /= 0 then
         --  This is a reraise, no need to store a new (wrong) chain.
         return;
      end if;

      System.Traceback.Call_Chain
        (Excep.Tracebacks'Address,
         Max_Tracebacks,
         Excep.Num_Tracebacks,
         AAA'Address,
         ZZZ'Address);
   end Call_Chain;

   ------------------------------
   -- Current_Target_Exception --
   ------------------------------

   function Current_Target_Exception return Exception_Occurrence is
   begin
      return Null_Occurrence;
   end Current_Target_Exception;

   -------------------
   -- EId_To_String --
   -------------------

   function EId_To_String (X : Exception_Id) return String is
   begin
      if X = Null_Id then
         return "";
      else
         return Exception_Name (X);
      end if;
   end EId_To_String;

   ------------------
   -- EO_To_String --
   ------------------

   --  We use the null string to represent the null occurrence, otherwise
   --  we output the Exception_Information string for the occurrence.

   function EO_To_String (X : Exception_Occurrence) return String is
   begin
      if X.Id = Null_Id then
         return "";
      else
         return Exception_Information (X);
      end if;
   end EO_To_String;

   ------------------------
   -- Exception_Identity --
   ------------------------

   function Exception_Identity
     (X    : Exception_Occurrence)
      return Exception_Id
   is
   begin
      if X.Id = Null_Id then
         raise Constraint_Error;
      else
         return X.Id;
      end if;
   end Exception_Identity;

   ---------------------------
   -- Exception_Information --
   ---------------------------

   --  The format of the string is:

   --    Exception_Name: nnnnn
   --    Message: mmmmm
   --    PID: ppp
   --    Call stack traceback locations:
   --    0xhhhh 0xhhhh 0xhhhh ... 0xhhh

   --  where

   --    nnnn is the fully qualified name of the exception in all upper
   --    case letters. This line is always present.

   --    mmmm is the message (this line present only if message is non-null)

   --    ppp is the Process Id value as a decimal integer (this line is
   --    present only if the Process Id is non-zero). Currently we are
   --    not making use of this field.

   --    The Call stack traceback locations line and the following values
   --    are present only if at least one traceback location was recorded.
   --    the values are given in C style format, with lower case letters
   --    for a-f, and only as many digits present as are necessary.

   --  The line terminator sequence at the end of each line, including the
   --  last line is a CR-LF sequence (16#0D# followed by 16#0A#).

   --  The Exception_Name and Message lines are omitted in the abort
   --  signal case, since this is not really an exception, and the only
   --  use of this routine is internal for printing termination output.

   --  WARNING: if the format of the generated string is changed, please note
   --  that an equivalent modification to the routine String_To_EO must be
   --  made to preserve proper functioning of the stream attributes.

   function Exception_Information (X : Exception_Occurrence) return String is

      --  This information is now built using the circuitry introduced in
      --  association with the support of traceback decorators, as the
      --  catenation of the exception basic information and the call chain
      --  backtrace in its basic form.

      Basic_Info : constant String  := Basic_Exception_Information (X);
      Tback_Info : constant String  := Basic_Exception_Traceback (X);

      Basic_Len  : constant Natural := Basic_Info'Length;
      Tback_Len  : constant Natural := Tback_Info'Length;

      Info : String (1 .. Basic_Len + Tback_Len);
      Ptr  : Natural := 0;

   begin
      Append_Info_String (Basic_Info, Info, Ptr);
      Append_Info_String (Tback_Info, Info, Ptr);

      return Info;
   end Exception_Information;

   -----------------------
   -- Exception_Message --
   -----------------------

   function Exception_Message (X : Exception_Occurrence) return String is
   begin
      if X.Id = Null_Id then
         raise Constraint_Error;
      end if;

      return X.Msg (1 .. X.Msg_Length);
   end Exception_Message;

   --------------------
   -- Exception_Name --
   --------------------

   function Exception_Name (Id : Exception_Id) return String is
   begin
      if Id = null then
         raise Constraint_Error;
      end if;

      return Id.Full_Name.all (1 .. Id.Name_Length - 1);
   end Exception_Name;

   function Exception_Name (X : Exception_Occurrence) return String is
   begin
      return Exception_Name (X.Id);
   end Exception_Name;

   ---------------------------
   -- Exception_Name_Simple --
   ---------------------------

   function Exception_Name_Simple (X : Exception_Occurrence) return String is
      Name : constant String := Exception_Name (X);
      P    : Natural;

   begin
      P := Name'Length;
      while P > 1 loop
         exit when Name (P - 1) = '.';
         P := P - 1;
      end loop;

      return Name (P .. Name'Length);
   end Exception_Name_Simple;

   -----------------------------
   -- Process_Raise_Exception --
   -----------------------------

   procedure Process_Raise_Exception
     (E                   : Exception_Id;
      From_Signal_Handler : Boolean)
   is
      pragma Inspection_Point (E);
      --  This is so the debugger can reliably inspect the parameter

      Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
      Mstate_Ptr  : constant Machine_State :=
                      Machine_State (Get_Machine_State_Addr.all);
      Excep       : EOA := Get_Current_Excep.all;

   begin
      --  WARNING : There should be no exception handler for this body
      --  because this would cause gigi to prepend a setup for a new
      --  jmpbuf to the sequence of statements. We would then always get
      --  this new buf in Jumpbuf_Ptr instead of the one for the exception
      --  we are handling, which would completely break the whole design
      --  of this procedure.

      --  Processing varies between zero cost and setjmp/lonjmp processing.

      if Zero_Cost_Exceptions /= 0 then

         --  Use the front-end tables to propagate if we have them, otherwise
         --  resort to the GCC back-end alternative. The backtrace for the
         --  occurrence is stored while walking up the stack, and thus stops
         --  in the handler's frame if there is one. Notifications are also
         --  not performed here since it is not yet known if the exception is
         --  handled.

         --  Set the machine state unless we are raising from a signal handler
         --  since it has already been set properly in that case.

         if not From_Signal_Handler then
            Set_Machine_State (Mstate_Ptr);
         end if;

         if Subprogram_Descriptors /= null then
            Propagate_Exception_With_FE_Support (Mstate_Ptr);
         else
            Propagate_Exception_With_GCC_Support (Mstate_Ptr);
         end if;

      else

         --  Compute the backtrace for this occurrence if the corresponding
         --  binder option has been set and we are not raising from a signal
         --  handler. Call_Chain takes care of the reraise case.

         if not From_Signal_Handler
           and then Exception_Tracebacks /= 0
         then
            Call_Chain (Excep);
         end if;

         --  If the jump buffer pointer is non-null, transfer control using
         --  it. Otherwise announce an unhandled exception (note that this
         --  means that we have no finalizations to do other than at the outer
         --  level). Perform the necessary notification tasks in both cases.

         if Jumpbuf_Ptr /= Null_Address then

            if not Excep.Exception_Raised then
               Excep.Exception_Raised := True;
               Notify_Handled_Exception (Null_Loc, False, False);

               --  The low level debugger notification is skipped from the
               --  call above because we do not have the necessary information
               --  to "feed" it properly.

            end if;

            builtin_longjmp (Jumpbuf_Ptr, 1);

         else
            Notify_Unhandled_Exception (E);
            Unhandled_Exception_Terminate;
         end if;
      end if;

   end Process_Raise_Exception;

   -----------------------------------------
   -- Propagate_Exception_With_FE_Support --
   -----------------------------------------

   procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is
      Excep  : constant EOA := Get_Current_Excep.all;
      Loc    : Code_Loc;
      Lo, Hi : Natural;
      Pdesc  : Natural;
      Hrec   : Handler_Record_Ptr;
      Info   : Subprogram_Info_Type;

      type Machine_State_Record is
        new Storage_Array (1 .. Machine_State_Length);
      for Machine_State_Record'Alignment use Standard'Maximum_Alignment;

      procedure Duplicate_Machine_State (Dest, Src : Machine_State);
      --  Copy Src into Dest, assuming that a Machine_State is pointing to
      --  an area of Machine_State_Length bytes.

      procedure Duplicate_Machine_State (Dest, Src : Machine_State) is
         type Machine_State_Record_Access is access Machine_State_Record;
         function To_MSR is new Unchecked_Conversion
           (Machine_State, Machine_State_Record_Access);

      begin
         To_MSR (Dest).all := To_MSR (Src).all;
      end Duplicate_Machine_State;

      --  Data for handling the finalization handler case. A simple approach
      --  in this routine would simply to unwind stack frames till we find a
      --  handler and then enter it. But this is undesirable in the case where
      --  we have only finalization handlers, and no "real" handler, i.e. a
      --  case where we have an unhandled exception.

      --  In this case we prefer to signal unhandled exception with the stack
      --  intact, and entering finalization handlers would destroy the stack
      --  state. To deal with this, as we unwind the stack, we note the first
      --  finalization handler, and remember it in the following variables.
      --  We then continue to unwind. If and when we find a "real", i.e. non-
      --  finalization handler, then we use these variables to pass control to
      --  the finalization handler.

      FH_Found : Boolean := False;
      --  Set when a finalization handler is found

      FH_Mstate : aliased Machine_State_Record;
      --  Records the machine state for the finalization handler

      FH_Handler : Code_Loc := Null_Address;
      --  Record handler address for finalization handler

      FH_Num_Trb : Natural := 0;
      --  Save number of tracebacks for finalization handler

   begin
      --  Loop through stack frames as exception propagates

      Main_Loop : loop
         Loc := Get_Code_Loc (Mstate);
         exit Main_Loop when Loc = Null_Loc;

         --  Record location unless it is inside this unit. Note: this
         --  test should really say Code_Address, but Address is the same
         --  as Code_Address for unnested subprograms, and Code_Address
         --  would cause a bootstrap problem

         if Loc < AAA'Address or else Loc > ZZZ'Address then

            --  Record location unless we already recorded max tracebacks

            if Excep.Num_Tracebacks /= Max_Tracebacks then

               --  Do not record location if it is the return point from
               --  a reraise call from within a cleanup handler

               if not Excep.Cleanup_Flag then
                  Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1;
                  Excep.Tracebacks (Excep.Num_Tracebacks) := Loc;

               --  For reraise call from cleanup handler, skip entry and
               --  clear the flag so that we will start to record again

               else
                  Excep.Cleanup_Flag := False;
               end if;
            end if;
         end if;

         --  Do binary search on procedure table

         Lo := 1;
         Hi := Num_Subprogram_Descriptors;

         --  Binary search loop

         loop
            Pdesc := (Lo + Hi) / 2;

            --  Note that Loc is expected to be the procedure's call point
            --  and not the return point.

            if Loc < Subprogram_Descriptors (Pdesc).Code then
               Hi := Pdesc - 1;

            elsif Pdesc < Num_Subprogram_Descriptors
              and then Loc > Subprogram_Descriptors (Pdesc + 1).Code
            then
               Lo := Pdesc + 1;

            else
               exit;
            end if;

            --  This happens when the current Loc is completely outside of
            --  the range of the program, which usually means that we reached
            --  the top level frame (e.g __start). In this case we have an
            --  unhandled exception.

            exit Main_Loop when Hi < Lo;
         end loop;

         --  Come here with Subprogram_Descriptors (Pdesc) referencing the
         --  procedure descriptor that applies to this PC value. Now do a
         --  serial search to see if any handler is applicable to this PC
         --  value, and to the exception that we are propagating

         for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop
            Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J);

            if Loc >= Hrec.Lo and then Loc < Hrec.Hi then

               --  PC range is applicable, see if handler is for this exception

               --  First test for case of "all others" (finalization) handler.
               --  We do not enter such a handler until we are sure there is
               --  a real handler further up the stack.

               if Hrec.Id = All_Others_Id then

                  --  If this is the first finalization handler, then
                  --  save the machine state so we can enter it later
                  --  without having to repeat the search.

                  if not FH_Found then
                     FH_Found   := True;
                     Duplicate_Machine_State
                       (Machine_State (FH_Mstate'Address), Mstate);
                     FH_Handler := Hrec.Handler;
                     FH_Num_Trb := Excep.Num_Tracebacks;
                  end if;

               --  Normal (non-finalization exception with matching Id)

               elsif Excep.Id = Hrec.Id
                 or else (Hrec.Id = Others_Id
                            and not Excep.Id.Not_Handled_By_Others)
               then
                  --  Perform the necessary notification tasks.

                  Notify_Handled_Exception
                    (Hrec.Handler, Hrec.Id = Others_Id, True);

                  --  If we already encountered a finalization handler, then
                  --  reset the context to that handler, and enter it.

                  if FH_Found then
                     Excep.Num_Tracebacks := FH_Num_Trb;
                     Excep.Cleanup_Flag   := True;

                     Enter_Handler
                       (Machine_State (FH_Mstate'Address), FH_Handler);

                  --  If we have not encountered a finalization handler,
                  --  then enter the current handler.

                  else
                     Enter_Handler (Mstate, Hrec.Handler);
                  end if;
               end if;
            end if;
         end loop;

         Info := Subprogram_Descriptors (Pdesc).Subprogram_Info;
         exit Main_Loop when Info = No_Info;
         Pop_Frame (Mstate, Info);
      end loop Main_Loop;

      --  Fall through if no "real" exception handler found. First thing is to
      --  perform the necessary notification tasks with the stack intact.

      Notify_Unhandled_Exception (Excep.Id);

      --  If there were finalization handlers, then enter the top one.
      --  Just because there is no handler does not mean we don't have
      --  to still execute all finalizations and cleanups before
      --  terminating. Note that the process of calling cleanups
      --  does not disturb the back trace stack, since he same
      --  exception occurrence gets reraised, and new traceback
      --  entries added as we go along.

      if FH_Found then
         Excep.Num_Tracebacks := FH_Num_Trb;
         Excep.Cleanup_Flag   := True;
         Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler);
      end if;

      --  If no cleanups, then this is the real unhandled termination

      Unhandled_Exception_Terminate;

   end Propagate_Exception_With_FE_Support;

   ------------------------------------------
   -- Propagate_Exception_With_GCC_Support --
   ------------------------------------------

   procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is
      Excep          : EOA := Get_Current_Excep.all;
      This_Exception : aliased GNAT_GCC_Exception;
      Status         : Unwind_Reason_Code;

   begin
      --  ??? Nothing is currently done for backtracing purposes. We could
      --  have used the personality routine to record the addresses while
      --  walking up the stack, but this method has two drawbacks : 1/ the
      --  trace is incomplete if the exception is handled since we don't walk
      --  up the frame with the handler, and 2/ we will miss frames if the
      --  exception propagates through frames for which our personality
      --  routine is not called (e.g. if C or C++ frames are on the way).

      --  Fill in the useful flags for the personality routine called for each
      --  frame via the call to Unwind_RaiseException below.

      This_Exception.Id := Excep.Id;
      This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
      This_Exception.Has_Cleanup := False;

      --  We are looking for a regular handler first. If there is one, either
      --  it or the first at-end handler before it will be entered. If there
      --  is none, control will normally get back to after the call, with
      --  Has_Cleanup set to true if at least one at-end handler has been
      --  found while walking up the stack.

      This_Exception.Select_Cleanups := False;

      Status := Unwind_RaiseException (This_Exception'Access);

      --  If we get here we know the exception is not handled, as otherwise
      --  Unwind_RaiseException arranges for a handler to be entered. We might
      --  have met cleanups handlers, though, requiring to start again with
      --  the Select_Cleanups flag set to True.

      --  Before restarting for cleanups, take the necessary steps to enable
      --  the debugger to gain control while the stack is still intact. Flag
      --  the occurrence as raised to avoid notifying again in case cleanup
      --  handlers are entered later.

      if not Excep.Exception_Raised then
         Excep.Exception_Raised := True;
         Notify_Unhandled_Exception (Excep.Id);
      end if;

      --  Now raise again selecting cleanups as true handlers. Only do this if
      --  we know at least one such handler exists since otherwise we would
      --  perform a complete stack upwalk for nothing.

      if This_Exception.Has_Cleanup then
         This_Exception.Select_Cleanups := True;
         Status := Unwind_RaiseException (This_Exception'Access);

         --  The first cleanup found is entered. It performs its job, raises
         --  the initial exception again, and the flow goes back to the first
         --  step above with the stack in a different state.
      end if;

      --  We get here when there is no handler to be run at all. The debugger
      --  has been notified before the second step above.

      Unhandled_Exception_Terminate;

   end Propagate_Exception_With_GCC_Support;

   ----------------------------
   -- Raise_Constraint_Error --
   ----------------------------

   procedure Raise_Constraint_Error
     (File : Big_String_Ptr;
      Line : Integer)
   is
   begin
      Raise_With_Location (Constraint_Error_Def'Access, File, Line);
   end Raise_Constraint_Error;

   --------------------------------
   -- Raise_Constraint_Error_Msg --
   --------------------------------

   procedure Raise_Constraint_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr)
   is
   begin
      Raise_With_Location_And_Msg
        (Constraint_Error_Def'Access, File, Line, Msg);
   end Raise_Constraint_Error_Msg;

   -------------------------
   -- Raise_Current_Excep --
   -------------------------

   procedure Raise_Current_Excep (E : Exception_Id) is
   begin
      Process_Raise_Exception (E => E, From_Signal_Handler => False);
   end Raise_Current_Excep;

   ---------------------
   -- Raise_Exception --
   ---------------------

   procedure Raise_Exception
     (E       : Exception_Id;
      Message : String := "")
   is
      Len : constant Natural :=
              Natural'Min (Message'Length, Exception_Msg_Max_Length);
      Excep : constant EOA := Get_Current_Excep.all;

   begin
      if E /= null then
         Excep.Msg_Length := Len;
         Excep.Msg (1 .. Len) := Message (1 .. Len);
         Raise_With_Msg (E);
      end if;
   end Raise_Exception;

   ----------------------------
   -- Raise_Exception_Always --
   ----------------------------

   procedure Raise_Exception_Always
     (E       : Exception_Id;
      Message : String := "")
   is
      Len : constant Natural :=
              Natural'Min (Message'Length, Exception_Msg_Max_Length);

      Excep : constant EOA := Get_Current_Excep.all;

   begin
      Excep.Msg_Length := Len;
      Excep.Msg (1 .. Len) := Message (1 .. Len);
      Raise_With_Msg (E);
   end Raise_Exception_Always;

   -------------------------------
   -- Raise_From_Signal_Handler --
   -------------------------------

   procedure Raise_From_Signal_Handler
     (E : Exception_Id;
      M : Big_String_Ptr)
   is
   begin
      Set_Exception_C_Msg (E, M);
      Abort_Defer.all;
      Process_Raise_Exception (E => E, From_Signal_Handler => True);
   end Raise_From_Signal_Handler;

   ------------------
   -- Raise_No_Msg --
   ------------------

   procedure Raise_No_Msg (E : Exception_Id) is
      Excep : constant EOA := Get_Current_Excep.all;

   begin
      Excep.Msg_Length := 0;
      Raise_With_Msg (E);
   end Raise_No_Msg;

   -------------------------
   -- Raise_Program_Error --
   -------------------------

   procedure Raise_Program_Error
     (File : Big_String_Ptr;
      Line : Integer)
   is
   begin
      Raise_With_Location (Program_Error_Def'Access, File, Line);
   end Raise_Program_Error;

   -----------------------------
   -- Raise_Program_Error_Msg --
   -----------------------------

   procedure Raise_Program_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr)
   is
   begin
      Raise_With_Location_And_Msg
        (Program_Error_Def'Access, File, Line, Msg);
   end Raise_Program_Error_Msg;

   -------------------------
   -- Raise_Storage_Error --
   -------------------------

   procedure Raise_Storage_Error
     (File : Big_String_Ptr;
      Line : Integer)
   is
   begin
      Raise_With_Location (Storage_Error_Def'Access, File, Line);
   end Raise_Storage_Error;

   -----------------------------
   -- Raise_Storage_Error_Msg --
   -----------------------------

   procedure Raise_Storage_Error_Msg
     (File : Big_String_Ptr;
      Line : Integer;
      Msg  : Big_String_Ptr)
   is
   begin
      Raise_With_Location_And_Msg
        (Storage_Error_Def'Access, File, Line, Msg);
   end Raise_Storage_Error_Msg;

   ----------------------
   -- Raise_With_C_Msg --
   ----------------------

   procedure Raise_With_C_Msg
     (E : Exception_Id;
      M : Big_String_Ptr)
   is
   begin
      Set_Exception_C_Msg (E, M);
      Abort_Defer.all;
      Raise_Current_Excep (E);
   end Raise_With_C_Msg;

   -------------------------
   -- Raise_With_Location --
   -------------------------

   procedure Raise_With_Location
     (E : Exception_Id;
      F : Big_String_Ptr;
      L : Integer)
   is
   begin
      Set_Exception_C_Msg (E, F, L);
      Abort_Defer.all;
      Raise_Current_Excep (E);
   end Raise_With_Location;

   ---------------------------------
   -- Raise_With_Location_And_Msg --
   ---------------------------------

   procedure Raise_With_Location_And_Msg
     (E : Exception_Id;
      F : Big_String_Ptr;
      L : Integer;
      M : Big_String_Ptr)
   is
   begin
      Set_Exception_C_Msg (E, F, L, M);
      Abort_Defer.all;
      Raise_Current_Excep (E);
   end Raise_With_Location_And_Msg;

   --------------------
   -- Raise_With_Msg --
   --------------------

   procedure Raise_With_Msg (E : Exception_Id) is
      Excep : constant EOA := Get_Current_Excep.all;

   begin
      Excep.Exception_Raised := False;
      Excep.Id               := E;
      Excep.Num_Tracebacks   := 0;
      Excep.Cleanup_Flag     := False;
      Excep.Pid              := Local_Partition_ID;
      Abort_Defer.all;
      Raise_Current_Excep (E);
   end Raise_With_Msg;

   -------------
   -- Reraise --
   -------------

   procedure Reraise is
      Excep : constant EOA := Get_Current_Excep.all;

   begin
      Abort_Defer.all;
      Raise_Current_Excep (Excep.Id);
   end Reraise;

   ------------------------
   -- Reraise_Occurrence --
   ------------------------

   procedure Reraise_Occurrence (X : Exception_Occurrence) is
   begin
      if X.Id /= null then
         Abort_Defer.all;
         Save_Occurrence (Get_Current_Excep.all.all, X);
         Raise_Current_Excep (X.Id);
      end if;
   end Reraise_Occurrence;

   -------------------------------
   -- Reraise_Occurrence_Always --
   -------------------------------

   procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
   begin
      Abort_Defer.all;
      Save_Occurrence (Get_Current_Excep.all.all, X);
      Raise_Current_Excep (X.Id);
   end Reraise_Occurrence_Always;

   ---------------------------------
   -- Reraise_Occurrence_No_Defer --
   ---------------------------------

   procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
   begin
      Save_Occurrence (Get_Current_Excep.all.all, X);
      Raise_Current_Excep (X.Id);
   end Reraise_Occurrence_No_Defer;

   ---------------------
   -- Save_Occurrence --
   ---------------------

   procedure Save_Occurrence
     (Target : out Exception_Occurrence;
      Source : Exception_Occurrence)
   is
   begin
      Target.Id             := Source.Id;
      Target.Msg_Length     := Source.Msg_Length;
      Target.Num_Tracebacks := Source.Num_Tracebacks;
      Target.Pid            := Source.Pid;
      Target.Cleanup_Flag   := Source.Cleanup_Flag;

      Target.Msg (1 .. Target.Msg_Length) :=
        Source.Msg (1 .. Target.Msg_Length);

      Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
        Source.Tracebacks (1 .. Target.Num_Tracebacks);
   end Save_Occurrence;

   function Save_Occurrence
     (Source : Exception_Occurrence)
      return   EOA
   is
      Target : EOA := new Exception_Occurrence;

   begin
      Save_Occurrence (Target.all, Source);
      return Target;
   end Save_Occurrence;

   ---------------------
   -- SDP_Table_Build --
   ---------------------

   procedure SDP_Table_Build
     (SDP_Addresses   : System.Address;
      SDP_Count       : Natural;
      Elab_Addresses  : System.Address;
      Elab_Addr_Count : Natural)
   is
      type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr;
      type SDLP_Array_Ptr is access all SDLP_Array;

      function To_SDLP_Array_Ptr is new Unchecked_Conversion
        (System.Address, SDLP_Array_Ptr);

      T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses);

      type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc;
      type Elab_Array_Ptr is access all Elab_Array;

      function To_Elab_Array_Ptr is new Unchecked_Conversion
        (System.Address, Elab_Array_Ptr);

      EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses);

      Ndes : Natural;
      Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr;

   begin
      --  If first call, then initialize count of subprogram descriptors

      if Subprogram_Descriptors = null then
         Num_Subprogram_Descriptors := 0;
      end if;

      --  First count number of subprogram descriptors. This count includes
      --  entries with duplicated code addresses (resulting from Import).

      Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count;
      for J in T'Range loop
         Ndes := Ndes + T (J).Count;
      end loop;

      --  Now, allocate the new table (extra zero'th element is for sort call)
      --  after having saved the previous one

      Previous_Subprogram_Descriptors := Subprogram_Descriptors;
      Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes);

      --  If there was a previous Subprogram_Descriptors table, copy it back
      --  into the new one being built. Then free the memory used for the
      --  previous table.

      for J in 1 .. Num_Subprogram_Descriptors loop
         Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J);
      end loop;

      Free (Previous_Subprogram_Descriptors);

      --  Next, append the elaboration routine addresses, building dummy
      --  SDP's for them as we go through the list.

      Ndes := Num_Subprogram_Descriptors;
      for J in EA'Range loop
         Ndes := Ndes + 1;
         Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0;

         Subprogram_Descriptors (Ndes).all :=
           Subprogram_Descriptor'
             (Num_Handlers    => 0,
              Code            => Fetch_Code (EA (J)),
              Subprogram_Info => EA (J),
              Handler_Records => (1 .. 0 => null));
      end loop;

      --  Now copy in pointers to SDP addresses of application subprograms

      for J in T'Range loop
         for K in 1 .. T (J).Count loop
            Ndes := Ndes + 1;
            Subprogram_Descriptors (Ndes) := T (J).SDesc (K);
            Subprogram_Descriptors (Ndes).Code :=
              Fetch_Code (T (J).SDesc (K).Code);
         end loop;
      end loop;

      --  Now we need to sort the table into ascending PC order

      Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access);

      --  Now eliminate duplicate entries. Note that in the case where
      --  entries have duplicate code addresses, the code for the Lt
      --  routine ensures that the interesting one (i.e. the one with
      --  handler entries if there are any) comes first.

      Num_Subprogram_Descriptors := 1;

      for J in 2 .. Ndes loop
         if Subprogram_Descriptors (J).Code /=
            Subprogram_Descriptors (Num_Subprogram_Descriptors).Code
         then
            Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1;
            Subprogram_Descriptors (Num_Subprogram_Descriptors) :=
              Subprogram_Descriptors (J);
         end if;
      end loop;

   end SDP_Table_Build;

   -----------------------
   -- SDP_Table_Sort_Lt --
   -----------------------

   function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is
      SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code;
      SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code;

   begin
      if SDC1 < SDC2 then
         return True;

      elsif SDC1 > SDC2 then
         return False;

      --  For two descriptors for the same procedure, we want the more
      --  interesting one first. A descriptor with an exception handler
      --  is more interesting than one without. This happens if the less
      --  interesting one came from a pragma Import.

      else
         return Subprogram_Descriptors (Op1).Num_Handlers /= 0
           and then Subprogram_Descriptors (Op2).Num_Handlers = 0;
      end if;
   end SDP_Table_Sort_Lt;

   --------------------------
   -- SDP_Table_Sort_Move --
   --------------------------

   procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is
   begin
      Subprogram_Descriptors (To) := Subprogram_Descriptors (From);
   end SDP_Table_Sort_Move;

   -------------------------
   -- Set_Exception_C_Msg --
   -------------------------

   procedure Set_Exception_C_Msg
     (Id   : Exception_Id;
      Msg1 : Big_String_Ptr;
      Line : Integer        := 0;
      Msg2 : Big_String_Ptr := null)
   is
      Excep  : constant EOA := Get_Current_Excep.all;
      Val    : Integer := Line;
      Remind : Integer;
      Size   : Integer := 1;
      Ptr    : Natural;

   begin
      Excep.Exception_Raised := False;
      Excep.Id               := Id;
      Excep.Num_Tracebacks   := 0;
      Excep.Pid              := Local_Partition_ID;
      Excep.Msg_Length       := 0;
      Excep.Cleanup_Flag     := False;

      while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL
        and then Excep.Msg_Length < Exception_Msg_Max_Length
      loop
         Excep.Msg_Length := Excep.Msg_Length + 1;
         Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length);
      end loop;

      --  Append line number if present

      if Line > 0 then

         --  Compute the number of needed characters

         while Val > 0 loop
            Val := Val / 10;
            Size := Size + 1;
         end loop;

         --  If enough characters are available, put the line number

         if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
            Excep.Msg (Excep.Msg_Length + 1) := ':';
            Excep.Msg_Length := Excep.Msg_Length + Size;
            Val := Line;
            Size := 0;

            while Val > 0 loop
               Remind := Val rem 10;
               Val := Val / 10;
               Excep.Msg (Excep.Msg_Length - Size) :=
                 Character'Val (Remind + Character'Pos ('0'));
               Size := Size + 1;
            end loop;
         end if;
      end if;

      --  Append second message if present

      if Msg2 /= null
        and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
      then
         Excep.Msg_Length := Excep.Msg_Length + 1;
         Excep.Msg (Excep.Msg_Length) := ' ';

         Ptr := 1;
         while Msg2 (Ptr) /= ASCII.NUL
           and then Excep.Msg_Length < Exception_Msg_Max_Length
         loop
            Excep.Msg_Length := Excep.Msg_Length + 1;
            Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr);
            Ptr := Ptr + 1;
         end loop;
      end if;
   end Set_Exception_C_Msg;

   -------------------
   -- String_To_EId --
   -------------------

   function String_To_EId (S : String) return Exception_Id is
   begin
      if S = "" then
         return Null_Id;
      else
         return Exception_Id (Internal_Exception (S));
      end if;
   end String_To_EId;

   ------------------
   -- String_To_EO --
   ------------------

   function String_To_EO (S : String) return Exception_Occurrence is
      From : Natural;
      To   : Integer;

      X : Exception_Occurrence;
      --  This is the exception occurrence we will create

      procedure Bad_EO;
      pragma No_Return (Bad_EO);
      --  Signal bad exception occurrence string

      procedure Next_String;
      --  On entry, To points to last character of previous line of the
      --  message, terminated by LF. On return, From .. To are set to
      --  specify the next string, or From > To if there are no more lines.

      procedure Bad_EO is
      begin
         Raise_Exception
           (Program_Error'Identity,
            "bad exception occurrence in stream input");
      end Bad_EO;

      procedure Next_String is
      begin
         From := To + 2;

         if From < S'Last then
            To := From + 1;

            while To < S'Last - 1 loop
               if To >= S'Last then
                  Bad_EO;
               elsif S (To + 1) = ASCII.LF then
                  exit;
               else
                  To := To + 1;
               end if;
            end loop;
         end if;
      end Next_String;

   --  Start of processing for String_To_EO

   begin
      if S = "" then
         return Null_Occurrence;

      else
         X.Cleanup_Flag := False;

         To := S'First - 2;
         Next_String;

         if S (From .. From + 15) /= "Exception name: " then
            Bad_EO;
         end if;

         X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));

         Next_String;

         if From <= To and then S (From) = 'M' then
            if S (From .. From + 8) /= "Message: " then
               Bad_EO;
            end if;

            X.Msg_Length := To - From - 8;
            X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
            Next_String;

         else
            X.Msg_Length := 0;
         end if;

         X.Pid := 0;

         if From <= To and then S (From) = 'P' then
            if S (From .. From + 3) /= "PID:" then
               Bad_EO;
            end if;

            From := From + 5; -- skip past PID: space

            while From <= To loop
               X.Pid := X.Pid * 10 +
                          (Character'Pos (S (From)) - Character'Pos ('0'));
               From := From + 1;
            end loop;

            Next_String;
         end if;

         X.Num_Tracebacks := 0;

         if From <= To then
            if S (From .. To) /= "Call stack traceback locations:" then
               Bad_EO;
            end if;

            Next_String;
            loop
               exit when From > To;

               declare
                  Ch : Character;
                  C  : Integer_Address;
                  N  : Integer_Address;

               begin
                  if S (From) /= '0'
                    or else S (From + 1) /= 'x'
                  then
                     Bad_EO;
                  else
                     From := From + 2;
                  end if;

                  C := 0;
                  while From <= To loop
                     Ch := S (From);

                     if Ch in '0' .. '9' then
                        N :=
                          Character'Pos (S (From)) - Character'Pos ('0');

                     elsif Ch in 'a' .. 'f' then
                        N :=
                          Character'Pos (S (From)) - Character'Pos ('a') + 10;

                     elsif Ch = ' ' then
                        From := From + 1;
                        exit;

                     else
                        Bad_EO;
                     end if;

                     C := C * 16 + N;

                     From := From + 1;
                  end loop;

                  if X.Num_Tracebacks = Max_Tracebacks then
                     Bad_EO;
                  end if;

                  X.Num_Tracebacks := X.Num_Tracebacks + 1;
                  X.Tracebacks (X.Num_Tracebacks) := To_Address (C);
               end;
            end loop;
         end if;

         --  If an exception was converted to a string, it must have
         --  already been raised, so flag it accordingly and we are done.

         X.Exception_Raised := True;
         return X;
      end if;
   end String_To_EO;

   ----------------------------------
   -- Tailored_Exception_Traceback --
   ----------------------------------

   function Tailored_Exception_Traceback
     (X    : Exception_Occurrence)
      return String
   is
      --  We indeed reference the decorator *wrapper* from here and not the
      --  decorator itself. The purpose of the local variable Wrapper is to
      --  prevent a potential crash by race condition in the code below. The
      --  atomicity of this assignment is enforced by pragma Atomic in
      --  System.Soft_Links.

      --  The potential race condition here, if no local variable was used,
      --  relates to the test upon the wrapper's value and the call, which
      --  are not performed atomically. With the local variable, potential
      --  changes of the wrapper's global value between the test and the
      --  call become inoffensive.

      Wrapper : constant Traceback_Decorator_Wrapper_Call :=
                  Traceback_Decorator_Wrapper;

   begin
      if Wrapper = null then
         return Basic_Exception_Traceback (X);
      else
         return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
      end if;
   end Tailored_Exception_Traceback;

   ------------------------------------
   -- Tailored_Exception_Information --
   ------------------------------------

   function Tailored_Exception_Information
     (X    : Exception_Occurrence)
      return String
   is
      --  The tailored exception information is simply the basic information
      --  associated with the tailored call chain backtrace.

      Basic_Info : constant String  := Basic_Exception_Information (X);
      Tback_Info : constant String  := Tailored_Exception_Traceback (X);

      Basic_Len  : constant Natural := Basic_Info'Length;
      Tback_Len  : constant Natural := Tback_Info'Length;

      Info : String (1 .. Basic_Len + Tback_Len);
      Ptr  : Natural := 0;

   begin
      Append_Info_String (Basic_Info, Info, Ptr);
      Append_Info_String (Tback_Info, Info, Ptr);

      return Info;
   end Tailored_Exception_Information;

   -------------------------
   -- Unhandled_Exception --
   -------------------------

   procedure Unhandled_Exception is
   begin
      null;
   end Unhandled_Exception;

   ----------------------
   -- Notify_Exception --
   ----------------------

   procedure Notify_Exception
     (Id        : Exception_Id;
      Handler   : Code_Loc;
      Is_Others : Boolean)
   is
   begin
      null;
   end Notify_Exception;

   ------------------------------
   -- Notify_Handled_Exception --
   ------------------------------

   procedure Notify_Handled_Exception
     (Handler    : Code_Loc;
      Is_Others  : Boolean;
      Low_Notify : Boolean)
   is
      Excep  : constant EOA := Get_Current_Excep.all;

   begin
      --  Notify the debugger that we have found a handler and are about to
      --  propagate an exception, but only if specifically told to do so.

      if Low_Notify then
         Notify_Exception (Excep.Id, Handler, Is_Others);
      end if;

      --  Output some exception information if necessary, as specified by
      --  GNAT.Exception_Traces. Take care not to output information about
      --  internal exceptions.
      --
      --  ??? In the ZCX case, the traceback entries we have at this point
      --  only include the ones we stored while walking up the stack *up to
      --  the handler*. All the frames above the subprogram in which the
      --  handler is found are missing.

      if Exception_Trace = Every_Raise
        and then not Excep.Id.Not_Handled_By_Others
      then
         To_Stderr (Nline);
         To_Stderr ("Exception raised");
         To_Stderr (Nline);
         To_Stderr (Tailored_Exception_Information (Excep.all));
      end if;

   end Notify_Handled_Exception;

   ------------------------------
   -- Notify_Handled_Exception --
   ------------------------------

   procedure Notify_Unhandled_Exception (Id : Exception_Id) is
   begin
      --  Simply perform the two necessary low level notification calls.

      Unhandled_Exception;
      Notify_Exception (Id, Null_Loc, False);

   end Notify_Unhandled_Exception;

   -----------------------------------
   -- Unhandled_Exception_Terminate --
   -----------------------------------

   adafinal_Called : Boolean := False;
   --  Used to prevent recursive call to adafinal in the event that
   --  adafinal processing itself raises an unhandled exception.

   type FILEs is new System.Address;
   type int is new Integer;

   procedure Unhandled_Exception_Terminate is

      Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
      --  This occurrence will be used to display a message after finalization.
      --  It is necessary to save a copy here, or else the designated value
      --  could be overwritten if an exception is raised during finalization
      --  (even if that exception is caught).

      Msg : constant String := Exception_Message (Excep.all);

   --  Start of processing for Unhandled_Exception_Terminate

   begin
      --  First call adafinal

      if not adafinal_Called then
         adafinal_Called := True;
         System.Soft_Links.Adafinal.all;
      end if;

      --  Check for special case of raising _ABORT_SIGNAL, which is not
      --  really an exception at all. We recognize this by the fact that
      --  it is the only exception whose name starts with underscore.

      if Exception_Name (Excep.all) (1) = '_' then
         To_Stderr (Nline);
         To_Stderr ("Execution terminated by abort of environment task");
         To_Stderr (Nline);

      --  If no tracebacks, we print the unhandled exception in the old style
      --  (i.e. the style used before ZCX was implemented). We do this to
      --  retain compatibility, especially with the nightly scripts, but
      --  this can be removed at some point ???

      elsif Excep.Num_Tracebacks = 0 then
         To_Stderr (Nline);
         To_Stderr ("raised ");
         To_Stderr (Exception_Name (Excep.all));

         if Msg'Length /= 0 then
            To_Stderr (" : ");
            To_Stderr (Msg);
         end if;

         To_Stderr (Nline);

      --  New style, zero cost exception case

      else
         --  Tailored_Exception_Information is also called here so that the
         --  backtrace decorator gets called if it has been set. This is
         --  currently required because some paths in Raise_Current_Excep
         --  do not go through the calls that display this information.
         --
         --  Note also that with the current scheme in Raise_Current_Excep
         --  we can have this whole information output twice, typically when
         --  some handler is found on the call chain but none deals with the
         --  occurrence or if this occurrence gets reraised up to here.

         To_Stderr (Nline);
         To_Stderr ("Execution terminated by unhandled exception");
         To_Stderr (Nline);
         To_Stderr (Tailored_Exception_Information (Excep.all));
      end if;

      --  Perform system dependent shutdown code

      declare
         procedure Unhandled_Terminate;
         pragma No_Return (Unhandled_Terminate);
         pragma Import
           (C, Unhandled_Terminate, "__gnat_unhandled_terminate");

      begin
         Unhandled_Terminate;
      end;

   end Unhandled_Exception_Terminate;

   ------------------------------
   -- Raise_Exception_No_Defer --
   ------------------------------

   procedure Raise_Exception_No_Defer
     (E       : Exception_Id;
      Message : String := "")
   is
      Len : constant Natural :=
              Natural'Min (Message'Length, Exception_Msg_Max_Length);

      Excep : constant EOA := Get_Current_Excep.all;

   begin
      Excep.Exception_Raised := False;
      Excep.Msg_Length       := Len;
      Excep.Msg (1 .. Len)   := Message (1 .. Len);
      Excep.Id               := E;
      Excep.Num_Tracebacks   := 0;
      Excep.Cleanup_Flag     := False;
      Excep.Pid              := Local_Partition_ID;

      --  DO NOT CALL Abort_Defer.all; !!!!

      Raise_Current_Excep (E);
   end Raise_Exception_No_Defer;

   ---------------
   -- To_Stderr --
   ---------------

   procedure To_Stderr (S : String) is
      procedure put_char_stderr (C : int);
      pragma Import (C, put_char_stderr, "put_char_stderr");

   begin
      for J in 1 .. S'Length loop
         if S (J) /= ASCII.CR then
            put_char_stderr (Character'Pos (S (J)));
         end if;
      end loop;
   end To_Stderr;

   ---------
   -- ZZZ --
   ---------

   --  This dummy procedure gives us the end of the PC range for addresses
   --  within the exception unit itself. We hope that gigi/gcc keeps all the
   --  procedures in their original order!

   procedure ZZZ is
   begin
      null;
   end ZZZ;

begin
   --  Allocate the Non-Tasking Machine_State

   Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State));
end Ada.Exceptions;