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 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L A Y O U T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Repinfo; use Repinfo;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Layout is
------------------------
-- Local Declarations --
------------------------
SSU : constant Int := Ttypes.System_Storage_Unit;
-- Short hand for System_Storage_Unit
Vname : constant Name_Id := Name_uV;
-- Formal parameter name used for functions generated for size offset
-- values that depend on the discriminant. All such functions have the
-- following form:
--
-- function xxx (V : vtyp) return Unsigned is
-- begin
-- return ... expression involving V.discrim
-- end xxx;
-----------------------
-- Local Subprograms --
-----------------------
function Assoc_Add
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id;
-- This is like Make_Op_Add except that it optimizes some cases knowing
-- that associative rearrangement is allowed for constant folding if one
-- of the operands is a compile time known value.
function Assoc_Multiply
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id;
-- This is like Make_Op_Multiply except that it optimizes some cases
-- knowing that associative rearrangement is allowed for constant folding
-- if one of the operands is a compile time known value
function Assoc_Subtract
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id;
-- This is like Make_Op_Subtract except that it optimizes some cases
-- knowing that associative rearrangement is allowed for constant folding
-- if one of the operands is a compile time known value
function Bits_To_SU (N : Node_Id) return Node_Id;
-- This is used when we cross the boundary from static sizes in bits to
-- dynamic sizes in storage units. If the argument N is anything other
-- than an integer literal, it is returned unchanged, but if it is an
-- integer literal, then it is taken as a size in bits, and is replaced
-- by the corresponding size in storage units.
function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id;
-- Given expressions for the low bound (Lo) and the high bound (Hi),
-- Build an expression for the value hi-lo+1, converted to type
-- Standard.Unsigned. Takes care of the case where the operands
-- are of an enumeration type (so that the subtraction cannot be
-- done directly) by applying the Pos operator to Hi/Lo first.
procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id);
-- Given an array type or an array subtype E, compute whether its size
-- depends on the value of one or more discriminants and set the flag
-- Size_Depends_On_Discriminant accordingly. This need not be called
-- in front end layout mode since it does the computation on its own.
function Expr_From_SO_Ref
(Loc : Source_Ptr;
D : SO_Ref;
Comp : Entity_Id := Empty) return Node_Id;
-- Given a value D from a size or offset field, return an expression
-- representing the value stored. If the value is known at compile time,
-- then an N_Integer_Literal is returned with the appropriate value. If
-- the value references a constant entity, then an N_Identifier node
-- referencing this entity is returned. If the value denotes a size
-- function, then returns a call node denoting the given function, with
-- a single actual parameter that either refers to the parameter V of
-- an enclosing size function (if Comp is Empty or its type doesn't match
-- the function's formal), or else is a selected component V.c when Comp
-- denotes a component c whose type matches that of the function formal.
-- The Loc value is used for the Sloc value of constructed notes.
function SO_Ref_From_Expr
(Expr : Node_Id;
Ins_Type : Entity_Id;
Vtype : Entity_Id := Empty;
Make_Func : Boolean := False) return Dynamic_SO_Ref;
-- This routine is used in the case where a size/offset value is dynamic
-- and is represented by the expression Expr. SO_Ref_From_Expr checks if
-- the Expr contains a reference to the identifier V, and if so builds
-- a function depending on discriminants of the formal parameter V which
-- is of type Vtype. Otherwise, if the parameter Make_Func is True, then
-- Expr will be encapsulated in a parameterless function; if Make_Func is
-- False, then a constant entity with the value Expr is built. The result
-- is a Dynamic_SO_Ref to the created entity. Note that Vtype can be
-- omitted if Expr does not contain any reference to V, the created entity.
-- The declaration created is inserted in the freeze actions of Ins_Type,
-- which also supplies the Sloc for created nodes. This function also takes
-- care of making sure that the expression is properly analyzed and
-- resolved (which may not be the case yet if we build the expression
-- in this unit).
function Get_Max_SU_Size (E : Entity_Id) return Node_Id;
-- E is an array type or subtype that has at least one index bound that
-- is the value of a record discriminant. For such an array, the function
-- computes an expression that yields the maximum possible size of the
-- array in storage units. The result is not defined for any other type,
-- or for arrays that do not depend on discriminants, and it is a fatal
-- error to call this unless Size_Depends_On_Discriminant (E) is True.
procedure Layout_Array_Type (E : Entity_Id);
-- Front-end layout of non-bit-packed array type or subtype
procedure Layout_Record_Type (E : Entity_Id);
-- Front-end layout of record type
procedure Rewrite_Integer (N : Node_Id; V : Uint);
-- Rewrite node N with an integer literal whose value is V. The Sloc for
-- the new node is taken from N, and the type of the literal is set to a
-- copy of the type of N on entry.
procedure Set_And_Check_Static_Size
(E : Entity_Id;
Esiz : SO_Ref;
RM_Siz : SO_Ref);
-- This procedure is called to check explicit given sizes (possibly stored
-- in the Esize and RM_Size fields of E) against computed Object_Size
-- (Esiz) and Value_Size (RM_Siz) values. Appropriate errors and warnings
-- are posted if specified sizes are inconsistent with specified sizes. On
-- return, Esize and RM_Size fields of E are set (either from previously
-- given values, or from the newly computed values, as appropriate).
procedure Set_Composite_Alignment (E : Entity_Id);
-- This procedure is called for record types and subtypes, and also for
-- atomic array types and subtypes. If no alignment is set, and the size
-- is 2 or 4 (or 8 if the word size is 8), then the alignment is set to
-- match the size.
----------------------------
-- Adjust_Esize_Alignment --
----------------------------
procedure Adjust_Esize_Alignment (E : Entity_Id) is
Abits : Int;
Esize_Set : Boolean;
begin
-- Nothing to do if size unknown
if Unknown_Esize (E) then
return;
end if;
-- Determine if size is constrained by an attribute definition clause
-- which must be obeyed. If so, we cannot increase the size in this
-- routine.
-- For a type, the issue is whether an object size clause has been set.
-- A normal size clause constrains only the value size (RM_Size)
if Is_Type (E) then
Esize_Set := Has_Object_Size_Clause (E);
-- For an object, the issue is whether a size clause is present
else
Esize_Set := Has_Size_Clause (E);
end if;
-- If size is known it must be a multiple of the storage unit size
if Esize (E) mod SSU /= 0 then
-- If not, and size specified, then give error
if Esize_Set then
Error_Msg_NE
("size for& not a multiple of storage unit size",
Size_Clause (E), E);
return;
-- Otherwise bump up size to a storage unit boundary
else
Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU);
end if;
end if;
-- Now we have the size set, it must be a multiple of the alignment
-- nothing more we can do here if the alignment is unknown here.
if Unknown_Alignment (E) then
return;
end if;
-- At this point both the Esize and Alignment are known, so we need
-- to make sure they are consistent.
Abits := UI_To_Int (Alignment (E)) * SSU;
if Esize (E) mod Abits = 0 then
return;
end if;
-- Here we have a situation where the Esize is not a multiple of the
-- alignment. We must either increase Esize or reduce the alignment to
-- correct this situation.
-- The case in which we can decrease the alignment is where the
-- alignment was not set by an alignment clause, and the type in
-- question is a discrete type, where it is definitely safe to reduce
-- the alignment. For example:
-- t : integer range 1 .. 2;
-- for t'size use 8;
-- In this situation, the initial alignment of t is 4, copied from
-- the Integer base type, but it is safe to reduce it to 1 at this
-- stage, since we will only be loading a single storage unit.
if Is_Discrete_Type (Etype (E)) and then not Has_Alignment_Clause (E)
then
loop
Abits := Abits / 2;
exit when Esize (E) mod Abits = 0;
end loop;
Init_Alignment (E, Abits / SSU);
return;
end if;
-- Now the only possible approach left is to increase the Esize but we
-- can't do that if the size was set by a specific clause.
if Esize_Set then
Error_Msg_NE
("size for& is not a multiple of alignment",
Size_Clause (E), E);
-- Otherwise we can indeed increase the size to a multiple of alignment
else
Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits);
end if;
end Adjust_Esize_Alignment;
---------------
-- Assoc_Add --
---------------
function Assoc_Add
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id
is
L : Node_Id;
R : Uint;
begin
-- Case of right operand is a constant
if Compile_Time_Known_Value (Right_Opnd) then
L := Left_Opnd;
R := Expr_Value (Right_Opnd);
-- Case of left operand is a constant
elsif Compile_Time_Known_Value (Left_Opnd) then
L := Right_Opnd;
R := Expr_Value (Left_Opnd);
-- Neither operand is a constant, do the addition with no optimization
else
return Make_Op_Add (Loc, Left_Opnd, Right_Opnd);
end if;
-- Case of left operand is an addition
if Nkind (L) = N_Op_Add then
-- (C1 + E) + C2 = (C1 + C2) + E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
(Sinfo.Left_Opnd (L),
Expr_Value (Sinfo.Left_Opnd (L)) + R);
return L;
-- (E + C1) + C2 = E + (C1 + C2)
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) + R);
return L;
end if;
-- Case of left operand is a subtraction
elsif Nkind (L) = N_Op_Subtract then
-- (C1 - E) + C2 = (C1 + C2) - E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
(Sinfo.Left_Opnd (L),
Expr_Value (Sinfo.Left_Opnd (L)) + R);
return L;
-- (E - C1) + C2 = E - (C1 - C2)
-- If the type is unsigned then only do the optimization if C1 >= C2,
-- to avoid creating a negative literal that can't be used with the
-- unsigned type.
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L))
and then (not Is_Unsigned_Type (Etype (Sinfo.Right_Opnd (L)))
or else Expr_Value (Sinfo.Right_Opnd (L)) >= R)
then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) - R);
return L;
end if;
end if;
-- Not optimizable, do the addition
return Make_Op_Add (Loc, Left_Opnd, Right_Opnd);
end Assoc_Add;
--------------------
-- Assoc_Multiply --
--------------------
function Assoc_Multiply
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id
is
L : Node_Id;
R : Uint;
begin
-- Case of right operand is a constant
if Compile_Time_Known_Value (Right_Opnd) then
L := Left_Opnd;
R := Expr_Value (Right_Opnd);
-- Case of left operand is a constant
elsif Compile_Time_Known_Value (Left_Opnd) then
L := Right_Opnd;
R := Expr_Value (Left_Opnd);
-- Neither operand is a constant, do the multiply with no optimization
else
return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd);
end if;
-- Case of left operand is an multiplication
if Nkind (L) = N_Op_Multiply then
-- (C1 * E) * C2 = (C1 * C2) + E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
(Sinfo.Left_Opnd (L),
Expr_Value (Sinfo.Left_Opnd (L)) * R);
return L;
-- (E * C1) * C2 = E * (C1 * C2)
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) * R);
return L;
end if;
end if;
-- Not optimizable, do the multiplication
return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd);
end Assoc_Multiply;
--------------------
-- Assoc_Subtract --
--------------------
function Assoc_Subtract
(Loc : Source_Ptr;
Left_Opnd : Node_Id;
Right_Opnd : Node_Id) return Node_Id
is
L : Node_Id;
R : Uint;
begin
-- Case of right operand is a constant
if Compile_Time_Known_Value (Right_Opnd) then
L := Left_Opnd;
R := Expr_Value (Right_Opnd);
-- Right operand is a constant, do the subtract with no optimization
else
return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd);
end if;
-- Case of left operand is an addition
if Nkind (L) = N_Op_Add then
-- (C1 + E) - C2 = (C1 - C2) + E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
(Sinfo.Left_Opnd (L),
Expr_Value (Sinfo.Left_Opnd (L)) - R);
return L;
-- (E + C1) - C2 = E + (C1 - C2)
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) - R);
return L;
end if;
-- Case of left operand is a subtraction
elsif Nkind (L) = N_Op_Subtract then
-- (C1 - E) - C2 = (C1 - C2) + E
if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then
Rewrite_Integer
(Sinfo.Left_Opnd (L),
Expr_Value (Sinfo.Left_Opnd (L)) + R);
return L;
-- (E - C1) - C2 = E - (C1 + C2)
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then
Rewrite_Integer
(Sinfo.Right_Opnd (L),
Expr_Value (Sinfo.Right_Opnd (L)) + R);
return L;
end if;
end if;
-- Not optimizable, do the subtraction
return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd);
end Assoc_Subtract;
----------------
-- Bits_To_SU --
----------------
function Bits_To_SU (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Integer_Literal then
Set_Intval (N, (Intval (N) + (SSU - 1)) / SSU);
end if;
return N;
end Bits_To_SU;
--------------------
-- Compute_Length --
--------------------
function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Lo);
Typ : constant Entity_Id := Etype (Lo);
Lo_Op : Node_Id;
Hi_Op : Node_Id;
Lo_Dim : Uint;
Hi_Dim : Uint;
begin
-- If the bounds are First and Last attributes for the same dimension
-- and both have prefixes that denotes the same entity, then we create
-- and return a Length attribute. This may allow the back end to
-- generate better code in cases where it already has the length.
if Nkind (Lo) = N_Attribute_Reference
and then Attribute_Name (Lo) = Name_First
and then Nkind (Hi) = N_Attribute_Reference
and then Attribute_Name (Hi) = Name_Last
and then Is_Entity_Name (Prefix (Lo))
and then Is_Entity_Name (Prefix (Hi))
and then Entity (Prefix (Lo)) = Entity (Prefix (Hi))
then
Lo_Dim := Uint_1;
Hi_Dim := Uint_1;
if Present (First (Expressions (Lo))) then
Lo_Dim := Expr_Value (First (Expressions (Lo)));
end if;
if Present (First (Expressions (Hi))) then
Hi_Dim := Expr_Value (First (Expressions (Hi)));
end if;
if Lo_Dim = Hi_Dim then
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of
(Entity (Prefix (Lo)), Loc),
Attribute_Name => Name_Length,
Expressions => New_List
(Make_Integer_Literal (Loc, Lo_Dim)));
end if;
end if;
Lo_Op := New_Copy_Tree (Lo);
Hi_Op := New_Copy_Tree (Hi);
-- If type is enumeration type, then use Pos attribute to convert
-- to integer type for which subtraction is a permitted operation.
if Is_Enumeration_Type (Typ) then
Lo_Op :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Lo_Op));
Hi_Op :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Hi_Op));
end if;
return
Assoc_Add (Loc,
Left_Opnd =>
Assoc_Subtract (Loc,
Left_Opnd => Hi_Op,
Right_Opnd => Lo_Op),
Right_Opnd => Make_Integer_Literal (Loc, 1));
end Compute_Length;
----------------------
-- Expr_From_SO_Ref --
----------------------
function Expr_From_SO_Ref
(Loc : Source_Ptr;
D : SO_Ref;
Comp : Entity_Id := Empty) return Node_Id
is
Ent : Entity_Id;
begin
if Is_Dynamic_SO_Ref (D) then
Ent := Get_Dynamic_SO_Entity (D);
if Is_Discrim_SO_Function (Ent) then
-- If a component is passed in whose type matches the type of
-- the function formal, then select that component from the "V"
-- parameter rather than passing "V" directly.
if Present (Comp)
and then Base_Type (Etype (Comp)) =
Base_Type (Etype (First_Formal (Ent)))
then
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Vname),
Selector_Name => New_Occurrence_Of (Comp, Loc))));
else
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Vname)));
end if;
else
return New_Occurrence_Of (Ent, Loc);
end if;
else
return Make_Integer_Literal (Loc, D);
end if;
end Expr_From_SO_Ref;
---------------------
-- Get_Max_SU_Size --
---------------------
function Get_Max_SU_Size (E : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (E);
Indx : Node_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
S : Uint;
Len : Node_Id;
type Val_Status_Type is (Const, Dynamic);
type Val_Type (Status : Val_Status_Type := Const) is record
case Status is
when Const => Val : Uint;
when Dynamic => Nod : Node_Id;
end case;
end record;
-- Shows the status of the value so far. Const means that the value is
-- constant, and Val is the current constant value. Dynamic means that
-- the value is dynamic, and in this case Nod is the Node_Id of the
-- expression to compute the value.
Size : Val_Type;
-- Calculated value so far if Size.Status = Const,
-- or expression value so far if Size.Status = Dynamic.
SU_Convert_Required : Boolean := False;
-- This is set to True if the final result must be converted from bits
-- to storage units (rounding up to a storage unit boundary).
-----------------------
-- Local Subprograms --
-----------------------
procedure Max_Discrim (N : in out Node_Id);
-- If the node N represents a discriminant, replace it by the maximum
-- value of the discriminant.
procedure Min_Discrim (N : in out Node_Id);
-- If the node N represents a discriminant, replace it by the minimum
-- value of the discriminant.
-----------------
-- Max_Discrim --
-----------------
procedure Max_Discrim (N : in out Node_Id) is
begin
if Nkind (N) = N_Identifier
and then Ekind (Entity (N)) = E_Discriminant
then
N := Type_High_Bound (Etype (N));
end if;
end Max_Discrim;
-----------------
-- Min_Discrim --
-----------------
procedure Min_Discrim (N : in out Node_Id) is
begin
if Nkind (N) = N_Identifier
and then Ekind (Entity (N)) = E_Discriminant
then
N := Type_Low_Bound (Etype (N));
end if;
end Min_Discrim;
-- Start of processing for Get_Max_SU_Size
begin
pragma Assert (Size_Depends_On_Discriminant (E));
-- Initialize status from component size
if Known_Static_Component_Size (E) then
Size := (Const, Component_Size (E));
else
Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E)));
end if;
-- Loop through indexes
Indx := First_Index (E);
while Present (Indx) loop
Ityp := Etype (Indx);
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
Min_Discrim (Lo);
Max_Discrim (Hi);
-- Value of the current subscript range is statically known
if Compile_Time_Known_Value (Lo)
and then
Compile_Time_Known_Value (Hi)
then
S := Expr_Value (Hi) - Expr_Value (Lo) + 1;
-- If known flat bound, entire size of array is zero
if S <= 0 then
return Make_Integer_Literal (Loc, 0);
end if;
-- Current value is constant, evolve value
if Size.Status = Const then
Size.Val := Size.Val * S;
-- Current value is dynamic
else
-- An interesting little optimization, if we have a pending
-- conversion from bits to storage units, and the current
-- length is a multiple of the storage unit size, then we
-- can take the factor out here statically, avoiding some
-- extra dynamic computations at the end.
if SU_Convert_Required and then S mod SSU = 0 then
S := S / SSU;
SU_Convert_Required := False;
end if;
Size.Nod :=
Assoc_Multiply (Loc,
Left_Opnd => Size.Nod,
Right_Opnd =>
Make_Integer_Literal (Loc, Intval => S));
end if;
-- Value of the current subscript range is dynamic
else
-- If the current size value is constant, then here is where we
-- make a transition to dynamic values, which are always stored
-- in storage units, However, we do not want to convert to SU's
-- too soon, consider the case of a packed array of single bits,
-- we want to do the SU conversion after computing the size in
-- this case.
if Size.Status = Const then
-- If the current value is a multiple of the storage unit,
-- then most certainly we can do the conversion now, simply
-- by dividing the current value by the storage unit value.
-- If this works, we set SU_Convert_Required to False.
if Size.Val mod SSU = 0 then
Size :=
(Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU));
SU_Convert_Required := False;
-- Otherwise, we go ahead and convert the value in bits, and
-- set SU_Convert_Required to True to ensure that the final
-- value is indeed properly converted.
else
Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val));
SU_Convert_Required := True;
end if;
end if;
-- Length is hi-lo+1
Len := Compute_Length (Lo, Hi);
-- Check possible range of Len
declare
OK : Boolean;
LLo : Uint;
LHi : Uint;
pragma Warnings (Off, LHi);
begin
Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If we cannot verify that range cannot be super-flat, we need
-- a max with zero, since length must be non-negative.
if not OK or else LLo < 0 then
Len :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Unsigned, Loc),
Attribute_Name => Name_Max,
Expressions => New_List (
Make_Integer_Literal (Loc, 0),
Len));
end if;
end;
end if;
Next_Index (Indx);
end loop;
-- Here after processing all bounds to set sizes. If the value is a
-- constant, then it is bits, so we convert to storage units.
if Size.Status = Const then
return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val));
-- Case where the value is dynamic
else
-- Do convert from bits to SU's if needed
if SU_Convert_Required then
-- The expression required is (Size.Nod + SU - 1) / SU
Size.Nod :=
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Size.Nod,
Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)),
Right_Opnd => Make_Integer_Literal (Loc, SSU));
end if;
return Size.Nod;
end if;
end Get_Max_SU_Size;
-----------------------
-- Layout_Array_Type --
-----------------------
procedure Layout_Array_Type (E : Entity_Id) is
Loc : constant Source_Ptr := Sloc (E);
Ctyp : constant Entity_Id := Component_Type (E);
Indx : Node_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
S : Uint;
Len : Node_Id;
Insert_Typ : Entity_Id;
-- This is the type with which any generated constants or functions
-- will be associated (i.e. inserted into the freeze actions). This
-- is normally the type being laid out. The exception occurs when
-- we are laying out Itype's which are local to a record type, and
-- whose scope is this record type. Such types do not have freeze
-- nodes (because we have no place to put them).
------------------------------------
-- How An Array Type is Laid Out --
------------------------------------
-- Here is what goes on. We need to multiply the component size of the
-- array (which has already been set) by the length of each of the
-- indexes. If all these values are known at compile time, then the
-- resulting size of the array is the appropriate constant value.
-- If the component size or at least one bound is dynamic (but no
-- discriminants are present), then the size will be computed as an
-- expression that calculates the proper size.
-- If there is at least one discriminant bound, then the size is also
-- computed as an expression, but this expression contains discriminant
-- values which are obtained by selecting from a function parameter, and
-- the size is given by a function that is passed the variant record in
-- question, and whose body is the expression.
type Val_Status_Type is (Const, Dynamic, Discrim);
type Val_Type (Status : Val_Status_Type := Const) is record
case Status is
when Const =>
Val : Uint;
-- Calculated value so far if Val_Status = Const
when Discrim
| Dynamic
=>
Nod : Node_Id;
-- Expression value so far if Val_Status /= Const
end case;
end record;
-- Records the value or expression computed so far. Const means that
-- the value is constant, and Val is the current constant value.
-- Dynamic means that the value is dynamic, and in this case Nod is
-- the Node_Id of the expression to compute the value, and Discrim
-- means that at least one bound is a discriminant, in which case Nod
-- is the expression so far (which will be the body of the function).
Size : Val_Type;
-- Value of size computed so far. See comments above
Vtyp : Entity_Id := Empty;
-- Variant record type for the formal parameter of the discriminant
-- function V if Status = Discrim.
SU_Convert_Required : Boolean := False;
-- This is set to True if the final result must be converted from
-- bits to storage units (rounding up to a storage unit boundary).
Storage_Divisor : Uint := UI_From_Int (SSU);
-- This is the amount that a nonstatic computed size will be divided
-- by to convert it from bits to storage units. This is normally
-- equal to SSU, but can be reduced in the case of packed components
-- that fit evenly into a storage unit.
Make_Size_Function : Boolean := False;
-- Indicates whether to request that SO_Ref_From_Expr should
-- encapsulate the array size expression in a function.
procedure Discrimify (N : in out Node_Id);
-- If N represents a discriminant, then the Size.Status is set to
-- Discrim, and Vtyp is set. The parameter N is replaced with the
-- proper expression to extract the discriminant value from V.
----------------
-- Discrimify --
----------------
procedure Discrimify (N : in out Node_Id) is
Decl : Node_Id;
Typ : Entity_Id;
begin
if Nkind (N) = N_Identifier
and then Ekind (Entity (N)) = E_Discriminant
then
Set_Size_Depends_On_Discriminant (E);
if Size.Status /= Discrim then
Decl := Parent (Parent (Entity (N)));
Size := (Discrim, Size.Nod);
Vtyp := Defining_Identifier (Decl);
end if;
Typ := Etype (N);
N :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Vname),
Selector_Name => New_Occurrence_Of (Entity (N), Loc));
-- Set the Etype attributes of the selected name and its prefix.
-- Analyze_And_Resolve can't be called here because the Vname
-- entity denoted by the prefix will not yet exist (it's created
-- by SO_Ref_From_Expr, called at the end of Layout_Array_Type).
Set_Etype (Prefix (N), Vtyp);
Set_Etype (N, Typ);
end if;
end Discrimify;
-- Start of processing for Layout_Array_Type
begin
-- Default alignment is component alignment
if Unknown_Alignment (E) then
Set_Alignment (E, Alignment (Ctyp));
end if;
-- Calculate proper type for insertions
if Is_Record_Type (Underlying_Type (Scope (E))) then
Insert_Typ := Underlying_Type (Scope (E));
else
Insert_Typ := E;
end if;
-- If the component type is a generic formal type then there's no point
-- in determining a size for the array type.
if Is_Generic_Type (Ctyp) then
return;
end if;
-- Deal with component size if base type
if Ekind (E) = E_Array_Type then
-- Cannot do anything if Esize of component type unknown
if Unknown_Esize (Ctyp) then
return;
end if;
-- Set component size if not set already
if Unknown_Component_Size (E) then
Set_Component_Size (E, Esize (Ctyp));
end if;
end if;
-- (RM 13.3 (48)) says that the size of an unconstrained array
-- is implementation defined. We choose to leave it as Unknown
-- here, and the actual behavior is determined by the back end.
if not Is_Constrained (E) then
return;
end if;
-- Initialize status from component size
if Known_Static_Component_Size (E) then
Size := (Const, Component_Size (E));
else
Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E)));
end if;
-- Loop to process array indexes
Indx := First_Index (E);
while Present (Indx) loop
Ityp := Etype (Indx);
-- If an index of the array is a generic formal type then there is
-- no point in determining a size for the array type.
if Is_Generic_Type (Ityp) then
return;
end if;
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
-- Value of the current subscript range is statically known
if Compile_Time_Known_Value (Lo)
and then
Compile_Time_Known_Value (Hi)
then
S := Expr_Value (Hi) - Expr_Value (Lo) + 1;
-- If known flat bound, entire size of array is zero
if S <= 0 then
Set_Esize (E, Uint_0);
Set_RM_Size (E, Uint_0);
return;
end if;
-- If constant, evolve value
if Size.Status = Const then
Size.Val := Size.Val * S;
-- Current value is dynamic
else
-- An interesting little optimization, if we have a pending
-- conversion from bits to storage units, and the current
-- length is a multiple of the storage unit size, then we
-- can take the factor out here statically, avoiding some
-- extra dynamic computations at the end.
if SU_Convert_Required and then S mod SSU = 0 then
S := S / SSU;
SU_Convert_Required := False;
end if;
-- Now go ahead and evolve the expression
Size.Nod :=
Assoc_Multiply (Loc,
Left_Opnd => Size.Nod,
Right_Opnd =>
Make_Integer_Literal (Loc, Intval => S));
end if;
-- Value of the current subscript range is dynamic
else
-- If the current size value is constant, then here is where we
-- make a transition to dynamic values, which are always stored
-- in storage units, However, we do not want to convert to SU's
-- too soon, consider the case of a packed array of single bits,
-- we want to do the SU conversion after computing the size in
-- this case.
if Size.Status = Const then
-- If the current value is a multiple of the storage unit,
-- then most certainly we can do the conversion now, simply
-- by dividing the current value by the storage unit value.
-- If this works, we set SU_Convert_Required to False.
if Size.Val mod SSU = 0 then
Size :=
(Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU));
SU_Convert_Required := False;
-- If the current value is a factor of the storage unit, then
-- we can use a value of one for the size and reduce the
-- strength of the later division.
elsif SSU mod Size.Val = 0 then
Storage_Divisor := SSU / Size.Val;
Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1));
SU_Convert_Required := True;
-- Otherwise, we go ahead and convert the value in bits, and
-- set SU_Convert_Required to True to ensure that the final
-- value is indeed properly converted.
else
Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val));
SU_Convert_Required := True;
end if;
end if;
Discrimify (Lo);
Discrimify (Hi);
-- Length is hi-lo+1
Len := Compute_Length (Lo, Hi);
-- If Len isn't a Length attribute, then its range needs to be
-- checked a possible Max with zero needs to be computed.
if Nkind (Len) /= N_Attribute_Reference
or else Attribute_Name (Len) /= Name_Length
then
declare
OK : Boolean;
LLo : Uint;
LHi : Uint;
begin
-- Check possible range of Len
Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If range definitely flat or superflat, result size is 0
if OK and then LHi <= 0 then
Set_Esize (E, Uint_0);
Set_RM_Size (E, Uint_0);
return;
end if;
-- If we cannot verify that range cannot be super-flat, we
-- need a max with zero, since length cannot be negative.
if not OK or else LLo < 0 then
Len :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Unsigned, Loc),
Attribute_Name => Name_Max,
Expressions => New_List (
Make_Integer_Literal (Loc, 0),
Len));
end if;
end;
end if;
-- At this stage, Len has the expression for the length
Size.Nod :=
Assoc_Multiply (Loc,
Left_Opnd => Size.Nod,
Right_Opnd => Len);
end if;
Next_Index (Indx);
end loop;
-- Here after processing all bounds to set sizes. If the value is a
-- constant, then it is bits, and the only thing we need to do is to
-- check against explicit given size and do alignment adjust.
if Size.Status = Const then
Set_And_Check_Static_Size (E, Size.Val, Size.Val);
Adjust_Esize_Alignment (E);
-- Case where the value is dynamic
else
-- Do convert from bits to SU's if needed
if SU_Convert_Required then
-- The expression required is:
-- (Size.Nod + Storage_Divisor - 1) / Storage_Divisor
Size.Nod :=
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Size.Nod,
Right_Opnd => Make_Integer_Literal
(Loc, Storage_Divisor - 1)),
Right_Opnd => Make_Integer_Literal (Loc, Storage_Divisor));
end if;
-- If the array entity is not declared at the library level and its
-- not nested within a subprogram that is marked for inlining, then
-- we request that the size expression be encapsulated in a function.
-- Since this expression is not needed in most cases, we prefer not
-- to incur the overhead of the computation on calls to the enclosing
-- subprogram except for subprograms that require the size.
if not Is_Library_Level_Entity (E) then
Make_Size_Function := True;
declare
Parent_Subp : Entity_Id := Enclosing_Subprogram (E);
begin
while Present (Parent_Subp) loop
if Is_Inlined (Parent_Subp) then
Make_Size_Function := False;
exit;
end if;
Parent_Subp := Enclosing_Subprogram (Parent_Subp);
end loop;
end;
end if;
-- Now set the dynamic size (the Value_Size is always the same as the
-- Object_Size for arrays whose length is dynamic).
-- ??? If Size.Status = Dynamic, Vtyp will not have been set.
-- The added initialization sets it to Empty now, but is this
-- correct?
Set_Esize
(E,
SO_Ref_From_Expr
(Size.Nod, Insert_Typ, Vtyp, Make_Func => Make_Size_Function));
Set_RM_Size (E, Esize (E));
end if;
end Layout_Array_Type;
------------------------------------------
-- Compute_Size_Depends_On_Discriminant --
------------------------------------------
procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id) is
Indx : Node_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
Res : Boolean := False;
begin
-- Loop to process array indexes
Indx := First_Index (E);
while Present (Indx) loop
Ityp := Etype (Indx);
-- If an index of the array is a generic formal type then there is
-- no point in determining a size for the array type.
if Is_Generic_Type (Ityp) then
return;
end if;
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
if (Nkind (Lo) = N_Identifier
and then Ekind (Entity (Lo)) = E_Discriminant)
or else
(Nkind (Hi) = N_Identifier
and then Ekind (Entity (Hi)) = E_Discriminant)
then
Res := True;
end if;
Next_Index (Indx);
end loop;
if Res then
Set_Size_Depends_On_Discriminant (E);
end if;
end Compute_Size_Depends_On_Discriminant;
-------------------
-- Layout_Object --
-------------------
procedure Layout_Object (E : Entity_Id) is
T : constant Entity_Id := Etype (E);
begin
-- Nothing to do if backend does layout
if not Frontend_Layout_On_Target then
return;
end if;
-- Set size if not set for object and known for type. Use the RM_Size if
-- that is known for the type and Esize is not.
if Unknown_Esize (E) then
if Known_Esize (T) then
Set_Esize (E, Esize (T));
elsif Known_RM_Size (T) then
Set_Esize (E, RM_Size (T));
end if;
end if;
-- Set alignment from type if unknown and type alignment known
if Unknown_Alignment (E) and then Known_Alignment (T) then
Set_Alignment (E, Alignment (T));
end if;
-- Make sure size and alignment are consistent
Adjust_Esize_Alignment (E);
-- Final adjustment, if we don't know the alignment, and the Esize was
-- not set by an explicit Object_Size attribute clause, then we reset
-- the Esize to unknown, since we really don't know it.
if Unknown_Alignment (E) and then not Has_Size_Clause (E) then
Set_Esize (E, Uint_0);
end if;
end Layout_Object;
------------------------
-- Layout_Record_Type --
------------------------
procedure Layout_Record_Type (E : Entity_Id) is
Loc : constant Source_Ptr := Sloc (E);
Decl : Node_Id;
Comp : Entity_Id;
-- Current component being laid out
Prev_Comp : Entity_Id;
-- Previous laid out component
procedure Get_Next_Component_Location
(Prev_Comp : Entity_Id;
Align : Uint;
New_Npos : out SO_Ref;
New_Fbit : out SO_Ref;
New_NPMax : out SO_Ref;
Force_SU : Boolean);
-- Given the previous component in Prev_Comp, which is already laid
-- out, and the alignment of the following component, lays out the
-- following component, and returns its starting position in New_Npos
-- (Normalized_Position value), New_Fbit (Normalized_First_Bit value),
-- and New_NPMax (Normalized_Position_Max value). If Prev_Comp is empty
-- (no previous component is present), then New_Npos, New_Fbit and
-- New_NPMax are all set to zero on return. This procedure is also
-- used to compute the size of a record or variant by giving it the
-- last component, and the record alignment. Force_SU is used to force
-- the new component location to be aligned on a storage unit boundary,
-- even in a packed record, False means that the new position does not
-- need to be bumped to a storage unit boundary, True means a storage
-- unit boundary is always required.
procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id);
-- Lays out component Comp, given Prev_Comp, the previously laid-out
-- component (Prev_Comp = Empty if no components laid out yet). The
-- alignment of the record itself is also updated if needed. Both
-- Comp and Prev_Comp can be either components or discriminants.
procedure Layout_Components
(From : Entity_Id;
To : Entity_Id;
Esiz : out SO_Ref;
RM_Siz : out SO_Ref);
-- This procedure lays out the components of the given component list
-- which contains the components starting with From and ending with To.
-- The Next_Entity chain is used to traverse the components. On entry,
-- Prev_Comp is set to the component preceding the list, so that the
-- list is laid out after this component. Prev_Comp is set to Empty if
-- the component list is to be laid out starting at the start of the
-- record. On return, the components are all laid out, and Prev_Comp is
-- set to the last laid out component. On return, Esiz is set to the
-- resulting Object_Size value, which is the length of the record up
-- to and including the last laid out entity. For Esiz, the value is
-- adjusted to match the alignment of the record. RM_Siz is similarly
-- set to the resulting Value_Size value, which is the same length, but
-- not adjusted to meet the alignment. Note that in the case of variant
-- records, Esiz represents the maximum size.
procedure Layout_Non_Variant_Record;
-- Procedure called to lay out a non-variant record type or subtype
procedure Layout_Variant_Record;
-- Procedure called to lay out a variant record type. Decl is set to the
-- full type declaration for the variant record.
---------------------------------
-- Get_Next_Component_Location --
---------------------------------
procedure Get_Next_Component_Location
(Prev_Comp : Entity_Id;
Align : Uint;
New_Npos : out SO_Ref;
New_Fbit : out SO_Ref;
New_NPMax : out SO_Ref;
Force_SU : Boolean)
is
begin
-- No previous component, return zero position
if No (Prev_Comp) then
New_Npos := Uint_0;
New_Fbit := Uint_0;
New_NPMax := Uint_0;
return;
end if;
-- Here we have a previous component
declare
Loc : constant Source_Ptr := Sloc (Prev_Comp);
Old_Npos : constant SO_Ref := Normalized_Position (Prev_Comp);
Old_Fbit : constant SO_Ref := Normalized_First_Bit (Prev_Comp);
Old_NPMax : constant SO_Ref := Normalized_Position_Max (Prev_Comp);
Old_Esiz : constant SO_Ref := Esize (Prev_Comp);
Old_Maxsz : Node_Id;
-- Expression representing maximum size of previous component
begin
-- Case where previous field had a dynamic size
if Is_Dynamic_SO_Ref (Esize (Prev_Comp)) then
-- If the previous field had a dynamic length, then it is
-- required to occupy an integral number of storage units,
-- and start on a storage unit boundary. This means that
-- the Normalized_First_Bit value is zero in the previous
-- component, and the new value is also set to zero.
New_Fbit := Uint_0;
-- In this case, the new position is given by an expression
-- that is the sum of old normalized position and old size.
New_Npos :=
SO_Ref_From_Expr
(Assoc_Add (Loc,
Left_Opnd =>
Expr_From_SO_Ref (Loc, Old_Npos),
Right_Opnd =>
Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp)),
Ins_Type => E,
Vtype => E);
-- Get maximum size of previous component
if Size_Depends_On_Discriminant (Etype (Prev_Comp)) then
Old_Maxsz := Get_Max_SU_Size (Etype (Prev_Comp));
else
Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp);
end if;
-- Now we can compute the new max position. If the max size
-- is static and the old position is static, then we can
-- compute the new position statically.
if Nkind (Old_Maxsz) = N_Integer_Literal
and then Known_Static_Normalized_Position_Max (Prev_Comp)
then
New_NPMax := Old_NPMax + Intval (Old_Maxsz);
-- Otherwise new max position is dynamic
else
New_NPMax :=
SO_Ref_From_Expr
(Assoc_Add (Loc,
Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax),
Right_Opnd => Old_Maxsz),
Ins_Type => E,
Vtype => E);
end if;
-- Previous field has known static Esize
else
New_Fbit := Old_Fbit + Old_Esiz;
-- Bump New_Fbit to storage unit boundary if required
if New_Fbit /= 0 and then Force_SU then
New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU;
end if;
-- If old normalized position is static, we can go ahead and
-- compute the new normalized position directly.
if Known_Static_Normalized_Position (Prev_Comp) then
New_Npos := Old_Npos;
if New_Fbit >= SSU then
New_Npos := New_Npos + New_Fbit / SSU;
New_Fbit := New_Fbit mod SSU;
end if;
-- Bump alignment if stricter than prev
if Align > Alignment (Etype (Prev_Comp)) then
New_Npos := (New_Npos + Align - 1) / Align * Align;
end if;
-- The max position is always equal to the position if
-- the latter is static, since arrays depending on the
-- values of discriminants never have static sizes.
New_NPMax := New_Npos;
return;
-- Case of old normalized position is dynamic
else
-- If new bit position is within the current storage unit,
-- we can just copy the old position as the result position
-- (we have already set the new first bit value).
if New_Fbit < SSU then
New_Npos := Old_Npos;
New_NPMax := Old_NPMax;
-- If new bit position is past the current storage unit, we
-- need to generate a new dynamic value for the position
-- ??? need to deal with alignment
else
New_Npos :=
SO_Ref_From_Expr
(Assoc_Add (Loc,
Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => New_Fbit / SSU)),
Ins_Type => E,
Vtype => E);
New_NPMax :=
SO_Ref_From_Expr
(Assoc_Add (Loc,
Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => New_Fbit / SSU)),
Ins_Type => E,
Vtype => E);
New_Fbit := New_Fbit mod SSU;
end if;
end if;
end if;
end;
end Get_Next_Component_Location;
----------------------
-- Layout_Component --
----------------------
procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id) is
Ctyp : constant Entity_Id := Etype (Comp);
ORC : constant Entity_Id := Original_Record_Component (Comp);
Npos : SO_Ref;
Fbit : SO_Ref;
NPMax : SO_Ref;
Forc : Boolean;
begin
-- Increase alignment of record if necessary. Note that we do not
-- do this for packed records, which have an alignment of one by
-- default, or for records for which an explicit alignment was
-- specified with an alignment clause.
if not Is_Packed (E)
and then not Has_Alignment_Clause (E)
and then Alignment (Ctyp) > Alignment (E)
then
Set_Alignment (E, Alignment (Ctyp));
end if;
-- If original component set, then use same layout
if Present (ORC) and then ORC /= Comp then
Set_Normalized_Position (Comp, Normalized_Position (ORC));
Set_Normalized_First_Bit (Comp, Normalized_First_Bit (ORC));
Set_Normalized_Position_Max (Comp, Normalized_Position_Max (ORC));
Set_Component_Bit_Offset (Comp, Component_Bit_Offset (ORC));
Set_Esize (Comp, Esize (ORC));
return;
end if;
-- Parent field is always at start of record, this will overlap
-- the actual fields that are part of the parent, and that's fine
if Chars (Comp) = Name_uParent then
Set_Normalized_Position (Comp, Uint_0);
Set_Normalized_First_Bit (Comp, Uint_0);
Set_Normalized_Position_Max (Comp, Uint_0);
Set_Component_Bit_Offset (Comp, Uint_0);
Set_Esize (Comp, Esize (Ctyp));
return;
end if;
-- Check case of type of component has a scope of the record we are
-- laying out. When this happens, the type in question is an Itype
-- that has not yet been laid out (that's because such types do not
-- get frozen in the normal manner, because there is no place for
-- the freeze nodes).
if Scope (Ctyp) = E then
Layout_Type (Ctyp);
end if;
-- If component already laid out, then we are done
if Known_Normalized_Position (Comp) then
return;
end if;
-- Set size of component from type. We use the Esize except in a
-- packed record, where we use the RM_Size (since that is what the
-- RM_Size value, as distinct from the Object_Size is useful for).
if Is_Packed (E) then
Set_Esize (Comp, RM_Size (Ctyp));
else
Set_Esize (Comp, Esize (Ctyp));
end if;
-- Compute the component position from the previous one. See if
-- current component requires being on a storage unit boundary.
-- If record is not packed, we always go to a storage unit boundary
if not Is_Packed (E) then
Forc := True;
-- Packed cases
else
-- Elementary types do not need SU boundary in packed record
if Is_Elementary_Type (Ctyp) then
Forc := False;
-- Packed array types with a modular packed array type do not
-- force a storage unit boundary (since the code generation
-- treats these as equivalent to the underlying modular type),
elsif Is_Array_Type (Ctyp)
and then Is_Bit_Packed_Array (Ctyp)
and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Ctyp))
then
Forc := False;
-- Record types with known length less than or equal to the length
-- of long long integer can also be unaligned, since they can be
-- treated as scalars.
elsif Is_Record_Type (Ctyp)
and then not Is_Dynamic_SO_Ref (Esize (Ctyp))
and then Esize (Ctyp) <= Esize (Standard_Long_Long_Integer)
then
Forc := False;
-- All other cases force a storage unit boundary, even when packed
else
Forc := True;
end if;
end if;
-- Now get the next component location
Get_Next_Component_Location
(Prev_Comp, Alignment (Ctyp), Npos, Fbit, NPMax, Forc);
Set_Normalized_Position (Comp, Npos);
Set_Normalized_First_Bit (Comp, Fbit);
Set_Normalized_Position_Max (Comp, NPMax);
-- Set Component_Bit_Offset in the static case
if Known_Static_Normalized_Position (Comp)
and then Known_Normalized_First_Bit (Comp)
then
Set_Component_Bit_Offset (Comp, SSU * Npos + Fbit);
end if;
end Layout_Component;
-----------------------
-- Layout_Components --
-----------------------
procedure Layout_Components
(From : Entity_Id;
To : Entity_Id;
Esiz : out SO_Ref;
RM_Siz : out SO_Ref)
is
End_Npos : SO_Ref;
End_Fbit : SO_Ref;
End_NPMax : SO_Ref;
begin
-- Only lay out components if there are some to lay out
if Present (From) then
-- Lay out components with no component clauses
Comp := From;
loop
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
then
-- The compatibility of component clauses with composite
-- types isn't checked in Sem_Ch13, so we check it here.
if Present (Component_Clause (Comp)) then
if Is_Composite_Type (Etype (Comp))
and then Esize (Comp) < RM_Size (Etype (Comp))
then
Error_Msg_Uint_1 := RM_Size (Etype (Comp));
Error_Msg_NE
("size for & too small, minimum allowed is ^",
Component_Clause (Comp),
Comp);
end if;
else
Layout_Component (Comp, Prev_Comp);
Prev_Comp := Comp;
end if;
end if;
exit when Comp = To;
Next_Entity (Comp);
end loop;
end if;
-- Set size fields, both are zero if no components
if No (Prev_Comp) then
Esiz := Uint_0;
RM_Siz := Uint_0;
-- If record subtype with non-static discriminants, then we don't
-- know which variant will be the one which gets chosen. We don't
-- just want to set the maximum size from the base, because the
-- size should depend on the particular variant.
-- What we do is to use the RM_Size of the base type, which has
-- the necessary conditional computation of the size, using the
-- size information for the particular variant chosen. Records
-- with default discriminants for example have an Esize that is
-- set to the maximum of all variants, but that's not what we
-- want for a constrained subtype.
elsif Ekind (E) = E_Record_Subtype
and then not Has_Static_Discriminants (E)
then
declare
BT : constant Node_Id := Base_Type (E);
begin
Esiz := RM_Size (BT);
RM_Siz := RM_Size (BT);
Set_Alignment (E, Alignment (BT));
end;
else
-- First the object size, for which we align past the last field
-- to the alignment of the record (the object size is required to
-- be a multiple of the alignment).
Get_Next_Component_Location
(Prev_Comp,
Alignment (E),
End_Npos,
End_Fbit,
End_NPMax,
Force_SU => True);
-- If the resulting normalized position is a dynamic reference,
-- then the size is dynamic, and is stored in storage units. In
-- this case, we set the RM_Size to the same value, it is simply
-- not worth distinguishing Esize and RM_Size values in the
-- dynamic case, since the RM has nothing to say about them.
-- Note that a size cannot have been given in this case, since
-- size specifications cannot be given for variable length types.
declare
Align : constant Uint := Alignment (E);
begin
if Is_Dynamic_SO_Ref (End_Npos) then
RM_Siz := End_Npos;
-- Set the Object_Size allowing for the alignment. In the
-- dynamic case, we must do the actual runtime computation.
-- We can skip this in the non-packed record case if the
-- last component has a smaller alignment than the overall
-- record alignment.
if Is_Dynamic_SO_Ref (End_NPMax) then
Esiz := End_NPMax;
if Is_Packed (E)
or else Alignment (Etype (Prev_Comp)) < Align
then
-- The expression we build is:
-- (expr + align - 1) / align * align
Esiz :=
SO_Ref_From_Expr
(Expr =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd =>
Expr_From_SO_Ref (Loc, Esiz),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => Align - 1)),
Right_Opnd =>
Make_Integer_Literal (Loc, Align)),
Right_Opnd =>
Make_Integer_Literal (Loc, Align)),
Ins_Type => E,
Vtype => E);
end if;
-- Here Esiz is static, so we can adjust the alignment
-- directly go give the required aligned value.
else
Esiz := (End_NPMax + Align - 1) / Align * Align * SSU;
end if;
-- Case where computed size is static
else
-- The ending size was computed in Npos in storage units,
-- but the actual size is stored in bits, so adjust
-- accordingly. We also adjust the size to match the
-- alignment here.
Esiz := (End_NPMax + Align - 1) / Align * Align * SSU;
-- Compute the resulting Value_Size (RM_Size). For this
-- purpose we do not force alignment of the record or
-- storage size alignment of the result.
Get_Next_Component_Location
(Prev_Comp,
Uint_0,
End_Npos,
End_Fbit,
End_NPMax,
Force_SU => False);
RM_Siz := End_Npos * SSU + End_Fbit;
Set_And_Check_Static_Size (E, Esiz, RM_Siz);
end if;
end;
end if;
end Layout_Components;
-------------------------------
-- Layout_Non_Variant_Record --
-------------------------------
procedure Layout_Non_Variant_Record is
Esiz : SO_Ref;
RM_Siz : SO_Ref;
begin
Layout_Components (First_Entity (E), Last_Entity (E), Esiz, RM_Siz);
Set_Esize (E, Esiz);
Set_RM_Size (E, RM_Siz);
end Layout_Non_Variant_Record;
---------------------------
-- Layout_Variant_Record --
---------------------------
procedure Layout_Variant_Record is
Tdef : constant Node_Id := Type_Definition (Decl);
First_Discr : Entity_Id;
Last_Discr : Entity_Id;
Esiz : SO_Ref;
RM_Siz : SO_Ref;
pragma Warnings (Off, SO_Ref);
RM_Siz_Expr : Node_Id := Empty;
-- Expression for the evolving RM_Siz value. This is typically an if
-- expression which involves tests of discriminant values that are
-- formed as references to the entity V. At the end of scanning all
-- the components, a suitable function is constructed in which V is
-- the parameter.
-----------------------
-- Local Subprograms --
-----------------------
procedure Layout_Component_List
(Clist : Node_Id;
Esiz : out SO_Ref;
RM_Siz_Expr : out Node_Id);
-- Recursive procedure, called to lay out one component list Esiz
-- and RM_Siz_Expr are set to the Object_Size and Value_Size values
-- respectively representing the record size up to and including the
-- last component in the component list (including any variants in
-- this component list). RM_Siz_Expr is returned as an expression
-- which may in the general case involve some references to the
-- discriminants of the current record value, referenced by selecting
-- from the entity V.
---------------------------
-- Layout_Component_List --
---------------------------
procedure Layout_Component_List
(Clist : Node_Id;
Esiz : out SO_Ref;
RM_Siz_Expr : out Node_Id)
is
Citems : constant List_Id := Component_Items (Clist);
Vpart : constant Node_Id := Variant_Part (Clist);
Prv : Node_Id;
Var : Node_Id;
RM_Siz : Uint;
RMS_Ent : Entity_Id;
begin
if Is_Non_Empty_List (Citems) then
Layout_Components
(From => Defining_Identifier (First (Citems)),
To => Defining_Identifier (Last (Citems)),
Esiz => Esiz,
RM_Siz => RM_Siz);
else
Layout_Components (Empty, Empty, Esiz, RM_Siz);
end if;
-- Case where no variants are present in the component list
if No (Vpart) then
-- The Esiz value has been correctly set by the call to
-- Layout_Components, so there is nothing more to be done.
-- For RM_Siz, we have an SO_Ref value, which we must convert
-- to an appropriate expression.
if Is_Static_SO_Ref (RM_Siz) then
RM_Siz_Expr :=
Make_Integer_Literal (Loc,
Intval => RM_Siz);
else
RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz);
-- If the size is represented by a function, then we create
-- an appropriate function call using V as the parameter to
-- the call.
if Is_Discrim_SO_Function (RMS_Ent) then
RM_Siz_Expr :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RMS_Ent, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Vname)));
-- If the size is represented by a constant, then the
-- expression we want is a reference to this constant
else
RM_Siz_Expr := New_Occurrence_Of (RMS_Ent, Loc);
end if;
end if;
-- Case where variants are present in this component list
else
declare
EsizV : SO_Ref;
RM_SizV : Node_Id;
Dchoice : Node_Id;
Discrim : Node_Id;
Dtest : Node_Id;
D_List : List_Id;
D_Entity : Entity_Id;
begin
RM_Siz_Expr := Empty;
Prv := Prev_Comp;
Var := Last (Variants (Vpart));
while Present (Var) loop
Prev_Comp := Prv;
Layout_Component_List
(Component_List (Var), EsizV, RM_SizV);
-- Set the Object_Size. If this is the first variant,
-- we just set the size of this first variant.
if Var = Last (Variants (Vpart)) then
Esiz := EsizV;
-- Otherwise the Object_Size is formed as a maximum
-- of Esiz so far from previous variants, and the new
-- Esiz value from the variant we just processed.
-- If both values are static, we can just compute the
-- maximum directly to save building junk nodes.
elsif not Is_Dynamic_SO_Ref (Esiz)
and then not Is_Dynamic_SO_Ref (EsizV)
then
Esiz := UI_Max (Esiz, EsizV);
-- If either value is dynamic, then we have to generate
-- an appropriate Standard_Unsigned'Max attribute call.
-- If one of the values is static then it needs to be
-- converted from bits to storage units to be compatible
-- with the dynamic value.
else
if Is_Static_SO_Ref (Esiz) then
Esiz := (Esiz + SSU - 1) / SSU;
end if;
if Is_Static_SO_Ref (EsizV) then
EsizV := (EsizV + SSU - 1) / SSU;
end if;
Esiz :=
SO_Ref_From_Expr
(Make_Attribute_Reference (Loc,
Attribute_Name => Name_Max,
Prefix =>
New_Occurrence_Of (Standard_Unsigned, Loc),
Expressions => New_List (
Expr_From_SO_Ref (Loc, Esiz),
Expr_From_SO_Ref (Loc, EsizV))),
Ins_Type => E,
Vtype => E);
end if;
-- Now deal with Value_Size (RM_Siz). We are aiming at
-- an expression that looks like:
-- if xxDx (V.disc) then rmsiz1
-- else if xxDx (V.disc) then rmsiz2
-- else ...
-- Where rmsiz1, rmsiz2... are the RM_Siz values for the
-- individual variants, and xxDx are the discriminant
-- checking functions generated for the variant type.
-- If this is the first variant, we simply set the result
-- as the expression. Note that this takes care of the
-- others case.
if No (RM_Siz_Expr) then
-- If this is the only variant and the size is a
-- literal, then use bit size as is, otherwise convert
-- to storage units and continue to the next variant.
if No (Prev (Var))
and then Nkind (RM_SizV) = N_Integer_Literal
then
RM_Siz_Expr := RM_SizV;
else
RM_Siz_Expr := Bits_To_SU (RM_SizV);
end if;
-- Otherwise construct the appropriate test
else
-- The test to be used in general is a call to the
-- discriminant checking function. However, it is
-- definitely worth special casing the very common
-- case where a single value is involved.
Dchoice := First (Discrete_Choices (Var));
if No (Next (Dchoice))
and then Nkind (Dchoice) /= N_Range
then
-- Discriminant to be tested
Discrim :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Vname),
Selector_Name =>
New_Occurrence_Of
(Entity (Name (Vpart)), Loc));
Dtest :=
Make_Op_Eq (Loc,
Left_Opnd => Discrim,
Right_Opnd => New_Copy (Dchoice));
-- Generate a call to the discriminant-checking
-- function for the variant. Note that the result
-- has to be complemented since the function returns
-- False when the passed discriminant value matches.
else
-- The checking function takes all of the type's
-- discriminants as parameters, so a list of all
-- the selected discriminants must be constructed.
D_List := New_List;
D_Entity := First_Discriminant (E);
while Present (D_Entity) loop
Append_To (D_List,
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Vname),
Selector_Name =>
New_Occurrence_Of (D_Entity, Loc)));
D_Entity := Next_Discriminant (D_Entity);
end loop;
Dtest :=
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
(Dcheck_Function (Var), Loc),
Parameter_Associations =>
D_List));
end if;
RM_Siz_Expr :=
Make_If_Expression (Loc,
Expressions =>
New_List
(Dtest, Bits_To_SU (RM_SizV), RM_Siz_Expr));
end if;
Prev (Var);
end loop;
end;
end if;
end Layout_Component_List;
Others_Present : Boolean;
pragma Warnings (Off, Others_Present);
-- Indicates others present, not used in this case
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
-- the variant part has a nonstatic choice.
package Variant_Choices_Processing is new
Generic_Check_Choices
(Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
use Variant_Choices_Processing;
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Flag_Non_Static_Expr
("choice given in case expression is not static!", Choice);
end Non_Static_Choice_Error;
-- Start of processing for Layout_Variant_Record
begin
-- Call Check_Choices here to ensure that Others_Discrete_Choices
-- gets set on any 'others' choice before the discriminant-checking
-- functions are generated. Otherwise the function for the 'others'
-- alternative will unconditionally return True, causing discriminant
-- checks to fail. However, Check_Choices is now normally delayed
-- until the type's freeze entity is processed, due to requirements
-- coming from subtype predicates, so doing it at this point is
-- probably not right in general, but it's not clear how else to deal
-- with this situation. Perhaps we should only generate declarations
-- for the checking functions here, and somehow delay generation of
-- their bodies, but that would be a nontrivial change. ???
declare
VP : constant Node_Id :=
Variant_Part (Component_List (Type_Definition (Decl)));
begin
Check_Choices
(VP, Variants (VP), Etype (Name (VP)), Others_Present);
end;
-- We need the discriminant checking functions, since we generate
-- calls to these functions for the RM_Size expression, so make
-- sure that these functions have been constructed in time.
Build_Discr_Checking_Funcs (Decl);
-- Lay out the discriminants
First_Discr := First_Discriminant (E);
Last_Discr := First_Discr;
while Present (Next_Discriminant (Last_Discr)) loop
Next_Discriminant (Last_Discr);
end loop;
Layout_Components
(From => First_Discr,
To => Last_Discr,
Esiz => Esiz,
RM_Siz => RM_Siz);
-- Lay out the main component list (this will make recursive calls
-- to lay out all component lists nested within variants).
Layout_Component_List (Component_List (Tdef), Esiz, RM_Siz_Expr);
Set_Esize (E, Esiz);
-- If the RM_Size is a literal, set its value
if Nkind (RM_Siz_Expr) = N_Integer_Literal then
Set_RM_Size (E, Intval (RM_Siz_Expr));
-- Otherwise we construct a dynamic SO_Ref
else
Set_RM_Size (E,
SO_Ref_From_Expr
(RM_Siz_Expr,
Ins_Type => E,
Vtype => E));
end if;
end Layout_Variant_Record;
-- Start of processing for Layout_Record_Type
begin
-- If this is a cloned subtype, just copy the size fields from the
-- original, nothing else needs to be done in this case, since the
-- components themselves are all shared.
if Ekind_In (E, E_Record_Subtype, E_Class_Wide_Subtype)
and then Present (Cloned_Subtype (E))
then
Set_Esize (E, Esize (Cloned_Subtype (E)));
Set_RM_Size (E, RM_Size (Cloned_Subtype (E)));
Set_Alignment (E, Alignment (Cloned_Subtype (E)));
-- Another special case, class-wide types. The RM says that the size
-- of such types is implementation defined (RM 13.3(48)). What we do
-- here is to leave the fields set as unknown values, and the backend
-- determines the actual behavior.
elsif Ekind (E) = E_Class_Wide_Type then
null;
-- All other cases
else
-- Initialize alignment conservatively to 1. This value will be
-- increased as necessary during processing of the record.
if Unknown_Alignment (E) then
Set_Alignment (E, Uint_1);
end if;
-- Initialize previous component. This is Empty unless there are
-- components which have already been laid out by component clauses.
-- If there are such components, we start our lay out of the
-- remaining components following the last such component.
Prev_Comp := Empty;
Comp := First_Component_Or_Discriminant (E);
while Present (Comp) loop
if Present (Component_Clause (Comp)) then
if No (Prev_Comp)
or else
Component_Bit_Offset (Comp) >
Component_Bit_Offset (Prev_Comp)
then
Prev_Comp := Comp;
end if;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
-- We have two separate circuits, one for non-variant records and
-- one for variant records. For non-variant records, we simply go
-- through the list of components. This handles all the non-variant
-- cases including those cases of subtypes where there is no full
-- type declaration, so the tree cannot be used to drive the layout.
-- For variant records, we have to drive the layout from the tree
-- since we need to understand the variant structure in this case.
if Present (Full_View (E)) then
Decl := Declaration_Node (Full_View (E));
else
Decl := Declaration_Node (E);
end if;
-- Scan all the components
if Nkind (Decl) = N_Full_Type_Declaration
and then Has_Discriminants (E)
and then Nkind (Type_Definition (Decl)) = N_Record_Definition
and then Present (Component_List (Type_Definition (Decl)))
and then
Present (Variant_Part (Component_List (Type_Definition (Decl))))
then
Layout_Variant_Record;
else
Layout_Non_Variant_Record;
end if;
end if;
end Layout_Record_Type;
-----------------
-- Layout_Type --
-----------------
procedure Layout_Type (E : Entity_Id) is
Desig_Type : Entity_Id;
begin
-- For string literal types, for now, kill the size always, this is
-- because gigi does not like or need the size to be set ???
if Ekind (E) = E_String_Literal_Subtype then
Set_Esize (E, Uint_0);
Set_RM_Size (E, Uint_0);
return;
end if;
-- For access types, set size/alignment. This is system address size,
-- except for fat pointers (unconstrained array access types), where the
-- size is two times the address size, to accommodate the two pointers
-- that are required for a fat pointer (data and template). Note that
-- E_Access_Protected_Subprogram_Type is not an access type for this
-- purpose since it is not a pointer but is equivalent to a record. For
-- access subtypes, copy the size from the base type since Gigi
-- represents them the same way.
if Is_Access_Type (E) then
Desig_Type := Underlying_Type (Designated_Type (E));
-- If we only have a limited view of the type, see whether the
-- non-limited view is available.
if From_Limited_With (Designated_Type (E))
and then Ekind (Designated_Type (E)) = E_Incomplete_Type
and then Present (Non_Limited_View (Designated_Type (E)))
then
Desig_Type := Non_Limited_View (Designated_Type (E));
end if;
-- If Esize already set (e.g. by a size clause), then nothing further
-- to be done here.
if Known_Esize (E) then
null;
-- Access to subprogram is a strange beast, and we let the backend
-- figure out what is needed (it may be some kind of fat pointer,
-- including the static link for example.
elsif Is_Access_Protected_Subprogram_Type (E) then
null;
-- For access subtypes, copy the size information from base type
elsif Ekind (E) = E_Access_Subtype then
Set_Size_Info (E, Base_Type (E));
Set_RM_Size (E, RM_Size (Base_Type (E)));
-- For other access types, we use either address size, or, if a fat
-- pointer is used (pointer-to-unconstrained array case), twice the
-- address size to accommodate a fat pointer.
elsif Present (Desig_Type)
and then Is_Array_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
and then not Has_Completion_In_Body (Desig_Type)
-- Debug Flag -gnatd6 says make all pointers to unconstrained thin
and then not Debug_Flag_6
then
Init_Size (E, 2 * System_Address_Size);
-- Check for bad convention set
if Warn_On_Export_Import
and then
(Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
then
Error_Msg_N
("?x?this access type does not correspond to C pointer", E);
end if;
-- If the designated type is a limited view it is unanalyzed. We can
-- examine the declaration itself to determine whether it will need a
-- fat pointer.
elsif Present (Desig_Type)
and then Present (Parent (Desig_Type))
and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (Desig_Type))) =
N_Unconstrained_Array_Definition
and then not Debug_Flag_6
then
Init_Size (E, 2 * System_Address_Size);
-- Normal case of thin pointer
else
Init_Size (E, System_Address_Size);
end if;
Set_Elem_Alignment (E);
-- Scalar types: set size and alignment
elsif Is_Scalar_Type (E) then
-- For discrete types, the RM_Size and Esize must be set already,
-- since this is part of the earlier processing and the front end is
-- always required to lay out the sizes of such types (since they are
-- available as static attributes). All we do is to check that this
-- rule is indeed obeyed.
if Is_Discrete_Type (E) then
-- If the RM_Size is not set, then here is where we set it
-- Note: an RM_Size of zero looks like not set here, but this
-- is a rare case, and we can simply reset it without any harm.
if not Known_RM_Size (E) then
Set_Discrete_RM_Size (E);
end if;
-- If Esize for a discrete type is not set then set it
if not Known_Esize (E) then
declare
S : Int := 8;
begin
loop
-- If size is big enough, set it and exit
if S >= RM_Size (E) then
Init_Esize (E, S);
exit;
-- If the RM_Size is greater than 64 (happens only when
-- strange values are specified by the user, then Esize
-- is simply a copy of RM_Size, it will be further
-- refined later on)
elsif S = 64 then
Set_Esize (E, RM_Size (E));
exit;
-- Otherwise double possible size and keep trying
else
S := S * 2;
end if;
end loop;
end;
end if;
-- For non-discrete scalar types, if the RM_Size is not set, then set
-- it now to a copy of the Esize if the Esize is set.
else
if Known_Esize (E) and then Unknown_RM_Size (E) then
Set_RM_Size (E, Esize (E));
end if;
end if;
Set_Elem_Alignment (E);
-- Non-elementary (composite) types
else
-- For packed arrays, take size and alignment values from the packed
-- array type if a packed array type has been created and the fields
-- are not currently set.
if Is_Array_Type (E)
and then Present (Packed_Array_Impl_Type (E))
then
declare
PAT : constant Entity_Id := Packed_Array_Impl_Type (E);
begin
if Unknown_Esize (E) then
Set_Esize (E, Esize (PAT));
end if;
if Unknown_RM_Size (E) then
Set_RM_Size (E, RM_Size (PAT));
end if;
if Unknown_Alignment (E) then
Set_Alignment (E, Alignment (PAT));
end if;
end;
end if;
-- If Esize is set, and RM_Size is not, RM_Size is copied from Esize.
-- At least for now this seems reasonable, and is in any case needed
-- for compatibility with old versions of gigi.
if Known_Esize (E) and then Unknown_RM_Size (E) then
Set_RM_Size (E, Esize (E));
end if;
-- For array base types, set component size if object size of the
-- component type is known and is a small power of 2 (8, 16, 32, 64),
-- since this is what will always be used.
if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then
declare
CT : constant Entity_Id := Component_Type (E);
begin
-- For some reason, access types can cause trouble, So let's
-- just do this for scalar types ???
if Present (CT)
and then Is_Scalar_Type (CT)
and then Known_Static_Esize (CT)
then
declare
S : constant Uint := Esize (CT);
begin
if Addressable (S) then
Set_Component_Size (E, S);
end if;
end;
end if;
end;
end if;
end if;
-- Lay out array and record types if front end layout set
if Frontend_Layout_On_Target then
if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then
Layout_Array_Type (E);
elsif Is_Record_Type (E) then
Layout_Record_Type (E);
end if;
-- Case of backend layout, we still do a little in the front end
else
-- Processing for record types
if Is_Record_Type (E) then
-- Special remaining processing for record types with a known
-- size of 16, 32, or 64 bits whose alignment is not yet set.
-- For these types, we set a corresponding alignment matching
-- the size if possible, or as large as possible if not.
if Convention (E) = Convention_Ada and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
-- Processing for array types
elsif Is_Array_Type (E) then
-- For arrays that are required to be atomic/VFA, we do the same
-- processing as described above for short records, since we
-- really need to have the alignment set for the whole array.
if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
-- For unpacked array types, set an alignment of 1 if we know
-- that the component alignment is not greater than 1. The reason
-- we do this is to avoid unnecessary copying of slices of such
-- arrays when passed to subprogram parameters (see special test
-- in Exp_Ch6.Expand_Actuals).
if not Is_Packed (E) and then Unknown_Alignment (E) then
if Known_Static_Component_Size (E)
and then Component_Size (E) = 1
then
Set_Alignment (E, Uint_1);
end if;
end if;
-- We need to know whether the size depends on the value of one
-- or more discriminants to select the return mechanism. Skip if
-- errors are present, to prevent cascaded messages.
if Serious_Errors_Detected = 0 then
Compute_Size_Depends_On_Discriminant (E);
end if;
end if;
end if;
-- Final step is to check that Esize and RM_Size are compatible
if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then
if Esize (E) < RM_Size (E) then
-- Esize is less than RM_Size. That's not good. First we test
-- whether this was set deliberately with an Object_Size clause
-- and if so, object to the clause.
if Has_Object_Size_Clause (E) then
Error_Msg_Uint_1 := RM_Size (E);
Error_Msg_F
("object size is too small, minimum allowed is ^",
Expression (Get_Attribute_Definition_Clause
(E, Attribute_Object_Size)));
end if;
-- Adjust Esize up to RM_Size value
declare
Size : constant Uint := RM_Size (E);
begin
Set_Esize (E, RM_Size (E));
-- For scalar types, increase Object_Size to power of 2, but
-- not less than a storage unit in any case (i.e., normally
-- this means it will be storage-unit addressable).
if Is_Scalar_Type (E) then
if Size <= System_Storage_Unit then
Init_Esize (E, System_Storage_Unit);
elsif Size <= 16 then
Init_Esize (E, 16);
elsif Size <= 32 then
Init_Esize (E, 32);
else
Set_Esize (E, (Size + 63) / 64 * 64);
end if;
-- Finally, make sure that alignment is consistent with
-- the newly assigned size.
while Alignment (E) * System_Storage_Unit < Esize (E)
and then Alignment (E) < Maximum_Alignment
loop
Set_Alignment (E, 2 * Alignment (E));
end loop;
end if;
end;
end if;
end if;
end Layout_Type;
---------------------
-- Rewrite_Integer --
---------------------
procedure Rewrite_Integer (N : Node_Id; V : Uint) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N, Make_Integer_Literal (Loc, Intval => V));
Set_Etype (N, Typ);
end Rewrite_Integer;
-------------------------------
-- Set_And_Check_Static_Size --
-------------------------------
procedure Set_And_Check_Static_Size
(E : Entity_Id;
Esiz : SO_Ref;
RM_Siz : SO_Ref)
is
SC : Node_Id;
procedure Check_Size_Too_Small (Spec : Uint; Min : Uint);
-- Spec is the number of bit specified in the size clause, and Min is
-- the minimum computed size. An error is given that the specified size
-- is too small if Spec < Min, and in this case both Esize and RM_Size
-- are set to unknown in E. The error message is posted on node SC.
procedure Check_Unused_Bits (Spec : Uint; Max : Uint);
-- Spec is the number of bits specified in the size clause, and Max is
-- the maximum computed size. A warning is given about unused bits if
-- Spec > Max. This warning is posted on node SC.
--------------------------
-- Check_Size_Too_Small --
--------------------------
procedure Check_Size_Too_Small (Spec : Uint; Min : Uint) is
begin
if Spec < Min then
Error_Msg_Uint_1 := Min;
Error_Msg_NE ("size for & too small, minimum allowed is ^", SC, E);
Init_Esize (E);
Init_RM_Size (E);
end if;
end Check_Size_Too_Small;
-----------------------
-- Check_Unused_Bits --
-----------------------
procedure Check_Unused_Bits (Spec : Uint; Max : Uint) is
begin
if Spec > Max then
Error_Msg_Uint_1 := Spec - Max;
Error_Msg_NE ("??^ bits of & unused", SC, E);
end if;
end Check_Unused_Bits;
-- Start of processing for Set_And_Check_Static_Size
begin
-- Case where Object_Size (Esize) is already set by a size clause
if Known_Static_Esize (E) then
SC := Size_Clause (E);
if No (SC) then
SC := Get_Attribute_Definition_Clause (E, Attribute_Object_Size);
end if;
-- Perform checks on specified size against computed sizes
if Present (SC) then
Check_Unused_Bits (Esize (E), Esiz);
Check_Size_Too_Small (Esize (E), RM_Siz);
end if;
end if;
-- Case where Value_Size (RM_Size) is set by specific Value_Size clause
-- (we do not need to worry about Value_Size being set by a Size clause,
-- since that will have set Esize as well, and we already took care of
-- that case).
if Known_Static_RM_Size (E) then
SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size);
-- Perform checks on specified size against computed sizes
if Present (SC) then
Check_Unused_Bits (RM_Size (E), Esiz);
Check_Size_Too_Small (RM_Size (E), RM_Siz);
end if;
end if;
-- Set sizes if unknown
if Unknown_Esize (E) then
Set_Esize (E, Esiz);
end if;
if Unknown_RM_Size (E) then
Set_RM_Size (E, RM_Siz);
end if;
end Set_And_Check_Static_Size;
-----------------------------
-- Set_Composite_Alignment --
-----------------------------
procedure Set_Composite_Alignment (E : Entity_Id) is
Siz : Uint;
Align : Nat;
begin
-- If alignment is already set, then nothing to do
if Known_Alignment (E) then
return;
end if;
-- Alignment is not known, see if we can set it, taking into account
-- the setting of the Optimize_Alignment mode.
-- If Optimize_Alignment is set to Space, then we try to give packed
-- records an aligmment of 1, unless there is some reason we can't.
if Optimize_Alignment_Space (E)
and then Is_Record_Type (E)
and then Is_Packed (E)
then
-- No effect for record with atomic/VFA components
if Is_Atomic_Or_VFA (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
if Is_Atomic (E) then
Error_Msg_N
("\pragma ignored for atomic record??", E);
else
Error_Msg_N
("\pragma ignored for bolatile full access record??", E);
end if;
return;
end if;
-- No effect if independent components
if Has_Independent_Components (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N
("\pragma ignored for record with independent components??", E);
return;
end if;
-- No effect if any component is atomic/VFA or is a by-reference type
declare
Ent : Entity_Id;
begin
Ent := First_Component_Or_Discriminant (E);
while Present (Ent) loop
if Is_By_Reference_Type (Etype (Ent))
or else Is_Atomic_Or_VFA (Etype (Ent))
or else Is_Atomic_Or_VFA (Ent)
then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then
Error_Msg_N
("\pragma is ignored if atomic "
& "components present??", E);
else
Error_Msg_N
("\pragma is ignored if bolatile full access "
& "components present??", E);
end if;
return;
else
Next_Component_Or_Discriminant (Ent);
end if;
end loop;
end;
-- Optimize_Alignment has no effect on variable length record
if not Size_Known_At_Compile_Time (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N ("\pragma is ignored for variable length record??", E);
return;
end if;
-- All tests passed, we can set alignment to 1
Align := 1;
-- Not a record, or not packed
else
-- The only other cases we worry about here are where the size is
-- statically known at compile time.
if Known_Static_Esize (E) then
Siz := Esize (E);
elsif Unknown_Esize (E) and then Known_Static_RM_Size (E) then
Siz := RM_Size (E);
else
return;
end if;
-- Size is known, alignment is not set
-- Reset alignment to match size if the known size is exactly 2, 4,
-- or 8 storage units.
if Siz = 2 * System_Storage_Unit then
Align := 2;
elsif Siz = 4 * System_Storage_Unit then
Align := 4;
elsif Siz = 8 * System_Storage_Unit then
Align := 8;
-- If Optimize_Alignment is set to Space, then make sure the
-- alignment matches the size, for example, if the size is 17
-- bytes then we want an alignment of 1 for the type.
elsif Optimize_Alignment_Space (E) then
if Siz mod (8 * System_Storage_Unit) = 0 then
Align := 8;
elsif Siz mod (4 * System_Storage_Unit) = 0 then
Align := 4;
elsif Siz mod (2 * System_Storage_Unit) = 0 then
Align := 2;
else
Align := 1;
end if;
-- If Optimize_Alignment is set to Time, then we reset for odd
-- "in between sizes", for example a 17 bit record is given an
-- alignment of 4.
elsif Optimize_Alignment_Time (E)
and then Siz > System_Storage_Unit
and then Siz <= 8 * System_Storage_Unit
then
if Siz <= 2 * System_Storage_Unit then
Align := 2;
elsif Siz <= 4 * System_Storage_Unit then
Align := 4;
else -- Siz <= 8 * System_Storage_Unit then
Align := 8;
end if;
-- No special alignment fiddling needed
else
return;
end if;
end if;
-- Here we have Set Align to the proposed improved value. Make sure the
-- value set does not exceed Maximum_Alignment for the target.
if Align > Maximum_Alignment then
Align := Maximum_Alignment;
end if;
-- Further processing for record types only to reduce the alignment
-- set by the above processing in some specific cases. We do not
-- do this for atomic/VFA records, since we need max alignment there,
if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then
-- For records, there is generally no point in setting alignment
-- higher than word size since we cannot do better than move by
-- words in any case. Omit this if we are optimizing for time,
-- since conceivably we may be able to do better.
if Align > System_Word_Size / System_Storage_Unit
and then not Optimize_Alignment_Time (E)
then
Align := System_Word_Size / System_Storage_Unit;
end if;
-- Check components. If any component requires a higher alignment,
-- then we set that higher alignment in any case. Don't do this if
-- we have Optimize_Alignment set to Space. Note that that covers
-- the case of packed records, where we already set alignment to 1.
if not Optimize_Alignment_Space (E) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (E);
while Present (Comp) loop
if Known_Alignment (Etype (Comp)) then
declare
Calign : constant Uint := Alignment (Etype (Comp));
begin
-- The cases to process are when the alignment of the
-- component type is larger than the alignment we have
-- so far, and either there is no component clause for
-- the component, or the length set by the component
-- clause matches the length of the component type.
if Calign > Align
and then
(Unknown_Esize (Comp)
or else (Known_Static_Esize (Comp)
and then
Esize (Comp) =
Calign * System_Storage_Unit))
then
Align := UI_To_Int (Calign);
end if;
end;
end if;
Next_Component (Comp);
end loop;
end;
end if;
end if;
-- Set chosen alignment, and increase Esize if necessary to match the
-- chosen alignment.
Set_Alignment (E, UI_From_Int (Align));
if Known_Static_Esize (E)
and then Esize (E) < Align * System_Storage_Unit
then
Set_Esize (E, UI_From_Int (Align * System_Storage_Unit));
end if;
end Set_Composite_Alignment;
--------------------------
-- Set_Discrete_RM_Size --
--------------------------
procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is
FST : constant Entity_Id := First_Subtype (Def_Id);
begin
-- All discrete types except for the base types in standard are
-- constrained, so indicate this by setting Is_Constrained.
Set_Is_Constrained (Def_Id);
-- Set generic types to have an unknown size, since the representation
-- of a generic type is irrelevant, in view of the fact that they have
-- nothing to do with code.
if Is_Generic_Type (Root_Type (FST)) then
Set_RM_Size (Def_Id, Uint_0);
-- If the subtype statically matches the first subtype, then it is
-- required to have exactly the same layout. This is required by
-- aliasing considerations.
elsif Def_Id /= FST and then
Subtypes_Statically_Match (Def_Id, FST)
then
Set_RM_Size (Def_Id, RM_Size (FST));
Set_Size_Info (Def_Id, FST);
-- In all other cases the RM_Size is set to the minimum size. Note that
-- this routine is never called for subtypes for which the RM_Size is
-- set explicitly by an attribute clause.
else
Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id)));
end if;
end Set_Discrete_RM_Size;
------------------------
-- Set_Elem_Alignment --
------------------------
procedure Set_Elem_Alignment (E : Entity_Id) is
begin
-- Do not set alignment for packed array types, unless we are doing
-- front end layout, because otherwise this is always handled in the
-- backend.
if Is_Packed_Array_Impl_Type (E)
and then not Frontend_Layout_On_Target
then
return;
-- If there is an alignment clause, then we respect it
elsif Has_Alignment_Clause (E) then
return;
-- If the size is not set, then don't attempt to set the alignment. This
-- happens in the backend layout case for access-to-subprogram types.
elsif not Known_Static_Esize (E) then
return;
-- For access types, do not set the alignment if the size is less than
-- the allowed minimum size. This avoids cascaded error messages.
elsif Is_Access_Type (E) and then Esize (E) < System_Address_Size then
return;
end if;
-- Here we calculate the alignment as the largest power of two multiple
-- of System.Storage_Unit that does not exceed either the object size of
-- the type, or the maximum allowed alignment.
declare
S : Int;
A : Nat;
Max_Alignment : Nat;
begin
-- The given Esize may be larger that int'last because of a previous
-- error, and the call to UI_To_Int will fail, so use default.
if Esize (E) / SSU > Ttypes.Maximum_Alignment then
S := Ttypes.Maximum_Alignment;
-- If this is an access type and the target doesn't have strict
-- alignment and we are not doing front end layout, then cap the
-- alignment to that of a regular access type. This will avoid
-- giving fat pointers twice the usual alignment for no practical
-- benefit since the misalignment doesn't really matter.
elsif Is_Access_Type (E)
and then not Target_Strict_Alignment
and then not Frontend_Layout_On_Target
then
S := System_Address_Size / SSU;
else
S := UI_To_Int (Esize (E)) / SSU;
end if;
-- If the default alignment of "double" floating-point types is
-- specifically capped, enforce the cap.
if Ttypes.Target_Double_Float_Alignment > 0
and then S = 8
and then Is_Floating_Point_Type (E)
then
Max_Alignment := Ttypes.Target_Double_Float_Alignment;
-- If the default alignment of "double" or larger scalar types is
-- specifically capped, enforce the cap.
elsif Ttypes.Target_Double_Scalar_Alignment > 0
and then S >= 8
and then Is_Scalar_Type (E)
then
Max_Alignment := Ttypes.Target_Double_Scalar_Alignment;
-- Otherwise enforce the overall alignment cap
else
Max_Alignment := Ttypes.Maximum_Alignment;
end if;
A := 1;
while 2 * A <= Max_Alignment and then 2 * A <= S loop
A := 2 * A;
end loop;
-- If alignment is currently not set, then we can safely set it to
-- this new calculated value.
if Unknown_Alignment (E) then
Init_Alignment (E, A);
-- Cases where we have inherited an alignment
-- For constructed types, always reset the alignment, these are
-- generally invisible to the user anyway, and that way we are
-- sure that no constructed types have weird alignments.
elsif not Comes_From_Source (E) then
Init_Alignment (E, A);
-- If this inherited alignment is the same as the one we computed,
-- then obviously everything is fine, and we do not need to reset it.
elsif Alignment (E) = A then
null;
else
-- Now we come to the difficult cases of subtypes for which we
-- have inherited an alignment different from the computed one.
-- We resort to the presence of alignment and size clauses to
-- guide our choices. Note that they can generally be present
-- only on the first subtype (except for Object_Size) and that
-- we need to look at the Rep_Item chain to correctly handle
-- derived types.
declare
FST : constant Entity_Id := First_Subtype (E);
function Has_Attribute_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean;
-- Wrapper around Get_Attribute_Definition_Clause which tests
-- for the presence of the specified attribute clause.
--------------------------
-- Has_Attribute_Clause --
--------------------------
function Has_Attribute_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean is
begin
return Present (Get_Attribute_Definition_Clause (E, Id));
end Has_Attribute_Clause;
begin
-- If the alignment comes from a clause, then we respect it.
-- Consider for example:
-- type R is new Character;
-- for R'Alignment use 1;
-- for R'Size use 16;
-- subtype S is R;
-- Here R has a specified size of 16 and a specified alignment
-- of 1, and it seems right for S to inherit both values.
if Has_Attribute_Clause (FST, Attribute_Alignment) then
null;
-- Now we come to the cases where we have inherited alignment
-- and size, and overridden the size but not the alignment.
elsif Has_Attribute_Clause (FST, Attribute_Size)
or else Has_Attribute_Clause (FST, Attribute_Object_Size)
or else Has_Attribute_Clause (E, Attribute_Object_Size)
then
-- This is tricky, it might be thought that we should try to
-- inherit the alignment, since that's what the RM implies,
-- but that leads to complex rules and oddities. Consider
-- for example:
-- type R is new Character;
-- for R'Size use 16;
-- It seems quite bogus in this case to inherit an alignment
-- of 1 from the parent type Character. Furthermore, if that
-- is what the programmer really wanted for some odd reason,
-- then he could specify the alignment directly.
-- Moreover we really don't want to inherit the alignment in
-- the case of a specified Object_Size for a subtype, since
-- there would be no way of overriding to give a reasonable
-- value (as we don't have an Object_Alignment attribute).
-- Consider for example:
-- subtype R is Character;
-- for R'Object_Size use 16;
-- If we inherit the alignment of 1, then it will be very
-- inefficient for the subtype and this cannot be fixed.
-- So we make the decision that if Size (or Object_Size) is
-- given and the alignment is not specified with a clause,
-- we reset the alignment to the appropriate value for the
-- specified size. This is a nice simple rule to implement
-- and document.
-- There is a theoretical glitch, which is that a confirming
-- size clause could now change the alignment, which, if we
-- really think that confirming rep clauses should have no
-- effect, could be seen as a no-no. However that's already
-- implemented by Alignment_Check_For_Size_Change so we do
-- not change the philosophy here.
-- Historical note: in versions prior to Nov 6th, 2011, an
-- odd distinction was made between inherited alignments
-- larger than the computed alignment (where the larger
-- alignment was inherited) and inherited alignments smaller
-- than the computed alignment (where the smaller alignment
-- was overridden). This was a dubious fix to get around an
-- ACATS problem which seems to have disappeared anyway, and
-- in any case, this peculiarity was never documented.
Init_Alignment (E, A);
-- If no Size (or Object_Size) was specified, then we have
-- inherited the object size, so we should also inherit the
-- alignment and not modify it.
else
null;
end if;
end;
end if;
end;
end Set_Elem_Alignment;
----------------------
-- SO_Ref_From_Expr --
----------------------
function SO_Ref_From_Expr
(Expr : Node_Id;
Ins_Type : Entity_Id;
Vtype : Entity_Id := Empty;
Make_Func : Boolean := False) return Dynamic_SO_Ref
is
Loc : constant Source_Ptr := Sloc (Ins_Type);
K : constant Entity_Id := Make_Temporary (Loc, 'K');
Decl : Node_Id;
Vtype_Primary_View : Entity_Id;
function Check_Node_V_Ref (N : Node_Id) return Traverse_Result;
-- Function used to check one node for reference to V
function Has_V_Ref is new Traverse_Func (Check_Node_V_Ref);
-- Function used to traverse tree to check for reference to V
----------------------
-- Check_Node_V_Ref --
----------------------
function Check_Node_V_Ref (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Identifier then
if Chars (N) = Vname then
return Abandon;
else
return Skip;
end if;
else
return OK;
end if;
end Check_Node_V_Ref;
-- Start of processing for SO_Ref_From_Expr
begin
-- Case of expression is an integer literal, in this case we just
-- return the value (which must always be non-negative, since size
-- and offset values can never be negative).
if Nkind (Expr) = N_Integer_Literal then
pragma Assert (Intval (Expr) >= 0);
return Intval (Expr);
end if;
-- Case where there is a reference to V, create function
if Has_V_Ref (Expr) = Abandon then
pragma Assert (Present (Vtype));
-- Check whether Vtype is a view of a private type and ensure that
-- we use the primary view of the type (which is denoted by its
-- Etype, whether it's the type's partial or full view entity).
-- This is needed to make sure that we use the same (primary) view
-- of the type for all V formals, whether the current view of the
-- type is the partial or full view, so that types will always
-- match on calls from one size function to another.
if Has_Private_Declaration (Vtype) then
Vtype_Primary_View := Etype (Vtype);
else
Vtype_Primary_View := Vtype;
end if;
Set_Is_Discrim_SO_Function (K);
Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => K,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Vname),
Parameter_Type =>
New_Occurrence_Of (Vtype_Primary_View, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Unsigned, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
-- The caller requests that the expression be encapsulated in a
-- parameterless function.
elsif Make_Func then
Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => K,
Parameter_Specifications => Empty_List,
Result_Definition =>
New_Occurrence_Of (Standard_Unsigned, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc, Expression => Expr))));
-- No reference to V and function not requested, so create a constant
else
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => K,
Object_Definition =>
New_Occurrence_Of (Standard_Unsigned, Loc),
Constant_Present => True,
Expression => Expr);
end if;
Append_Freeze_Action (Ins_Type, Decl);
Analyze (Decl);
return Create_Dynamic_SO_Ref (K);
end SO_Ref_From_Expr;
end Layout;
|