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
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
|
-- Semantic analysis pass.
-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT 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
-- along with this program. If not, see <gnu.org/licenses>.
with Errorout; use Errorout;
with Libraries;
with Std_Names;
with Flags; use Flags;
with Str_Table;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Std_Package; use Vhdl.Std_Package;
with Vhdl.Ieee.Std_Logic_1164;
with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes;
with Vhdl.Sem_Expr; use Vhdl.Sem_Expr;
with Vhdl.Sem_Names; use Vhdl.Sem_Names;
with Vhdl.Sem_Specs; use Vhdl.Sem_Specs;
with Vhdl.Sem_Decls; use Vhdl.Sem_Decls;
with Vhdl.Sem_Assocs; use Vhdl.Sem_Assocs;
with Vhdl.Sem_Types;
with Vhdl.Sem_Inst;
with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;
with Vhdl.Sem_Psl;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Sem_Utils;
with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts;
with Vhdl.Nodes_Utils;
with Vhdl.Xrefs; use Vhdl.Xrefs;
with Vhdl.Elocations;
package body Vhdl.Sem is
-- Forward declarations.
procedure Sem_Context_Clauses (Unit: Iir);
procedure Sem_Block_Configuration
(Block_Conf : Iir_Block_Configuration; Father: Iir);
procedure Sem_Component_Configuration
(Conf : Iir_Component_Configuration; Father : Iir);
procedure Add_Dependence (Unit : Iir)
is
Targ : constant Iir := Get_Current_Design_Unit;
begin
-- During normal analysis, there is a current design unit. But not
-- during debugging outside of any context.
if Targ = Null_Iir then
return;
end if;
Add_Dependence (Targ, Unit);
end Add_Dependence;
-- LRM 1.1 Entity declaration.
procedure Sem_Entity_Declaration (Entity : Iir_Entity_Declaration) is
begin
Xrefs.Xref_Decl (Entity);
Sem_Scopes.Add_Name (Entity);
Set_Visible_Flag (Entity, True);
Set_Is_Within_Flag (Entity, True);
-- LRM 10.1
-- 1. An entity declaration, together with a corresponding architecture
-- body.
Open_Declarative_Region;
-- Sem generics.
Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List);
-- Sem ports.
Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List);
-- Entity declarative part and concurrent statements.
Sem_Block (Entity);
Close_Declarative_Region;
Set_Is_Within_Flag (Entity, False);
end Sem_Entity_Declaration;
-- Get the entity unit for LIBRARY_UNIT (an architecture or a
-- configuration declaration).
-- Return NULL_IIR in case of error (not found, bad library).
function Sem_Entity_Name (Library_Unit : Iir) return Iir
is
Name : Iir;
Library : Iir_Library_Declaration;
Entity : Iir;
begin
-- Get the library of architecture/configuration.
Library := Get_Library
(Get_Design_File (Get_Design_Unit (Library_Unit)));
-- Resolve the name.
Name := Get_Entity_Name (Library_Unit);
if Is_Error (Name) then
pragma Assert (Flags.Flag_Force_Analysis);
return Null_Iir;
end if;
if Get_Kind (Name) = Iir_Kind_Simple_Name then
-- LRM93 10.1 Declarative Region
-- LRM08 12.1 Declarative Region
-- a) An entity declaration, tohether with a corresponding
-- architecture body.
--
-- GHDL: simple name needs to be handled specially. Because
-- architecture body is in the declarative region of its entity,
-- the entity name is directly visible. But we cannot really use
-- that rule as is, as we don't know which is the entity.
Entity := Load_Primary_Unit
(Library, Get_Identifier (Name), Library_Unit);
if Entity = Null_Iir then
Error_Msg_Sem (+Name, "entity %n was not analysed", +Name);
return Null_Iir;
end if;
Entity := Get_Library_Unit (Entity);
Set_Named_Entity (Name, Entity);
Xrefs.Xref_Ref (Name, Entity);
else
-- Certainly an expanded name. Use the standard name analysis.
Name := Sem_Denoting_Name (Name);
Set_Entity_Name (Library_Unit, Name);
Entity := Get_Named_Entity (Name);
end if;
if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then
Error_Class_Match (Name, "entity");
return Null_Iir;
end if;
-- LRM 1.2 Architecture bodies
-- For a given design entity, both the entity declaration and the
-- associated architecture body must reside in the same library.
-- LRM 1.3 Configuration Declarations
-- For a configuration of a given design entity, both the
-- configuration declaration and the corresponding entity
-- declaration must reside in the same library.
if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library
then
Error_Msg_Sem
(+Library_Unit, "%n does not reside in %n", (+Entity, +Library));
return Null_Iir;
end if;
return Entity;
end Sem_Entity_Name;
-- LRM 1.2 Architecture bodies.
procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body)
is
Entity_Unit : Iir_Design_Unit;
Entity_Library : Iir_Entity_Declaration;
begin
Xrefs.Xref_Decl (Arch);
-- First, find the entity.
Entity_Library := Sem_Entity_Name (Arch);
if Entity_Library = Null_Iir then
return;
end if;
Entity_Unit := Get_Design_Unit (Entity_Library);
-- LRM93 11.4
-- In each case, the second unit depends on the first unit.
-- GHDL: an architecture depends on its entity.
Add_Dependence (Entity_Unit);
Add_Context_Clauses (Entity_Unit);
Set_Is_Within_Flag (Arch, True);
Set_Is_Within_Flag (Entity_Library, True);
-- Makes the entity name visible.
-- FIXME: quote LRM.
declare
Prev_Hide : constant Boolean := Is_Warning_Enabled (Warnid_Hide);
begin
-- Avoid spurious warning from entity name (if it has the same
-- identifier as a library clause).
Enable_Warning (Warnid_Hide, False);
Sem_Scopes.Add_Name
(Entity_Library, Get_Identifier (Entity_Library), False);
Enable_Warning (Warnid_Hide, Prev_Hide);
end;
-- LRM 10.1 Declarative Region
-- 1. An entity declaration, together with a corresponding architecture
-- body.
Open_Declarative_Region;
Sem_Scopes.Add_Entity_Declarations (Entity_Library);
-- LRM02 1.2 Architecture bodies
-- For the purpose of interpreting the scope and visibility of the
-- identifier (see 10.2 and 10.3), the declaration of the identifier is
-- considered to occur after the final declarative item of the entity
-- declarative part of the corresponding entity declaration.
--
-- FIXME: before VHDL-02, an architecture is not a declaration.
Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True);
Set_Visible_Flag (Arch, True);
-- LRM02 10.1 Declarative region
-- The declarative region associated with an architecture body is
-- considered to occur immediatly within the declarative region
-- associated with the entity declaration corresponding to the given
-- architecture body.
--
-- GHDL: this is only in vhdl-2002.
if Vhdl_Std = Vhdl_02 then
Open_Declarative_Region;
end if;
Current_Psl_Default_Clock := Null_Iir;
Sem_Block (Arch);
if Vhdl_Std = Vhdl_02 then
Close_Declarative_Region;
end if;
Close_Declarative_Region;
Set_Is_Within_Flag (Arch, False);
Set_Is_Within_Flag (Entity_Library, False);
end Sem_Architecture_Body;
-- Return the real resolver used for (sub) object OBJ.
-- Return NULL_IIR if none.
function Get_Resolver (Obj : Iir) return Iir
is
Obj_Type : Iir;
Res : Iir;
begin
case Get_Kind (Obj) is
when Iir_Kind_Indexed_Name
| Iir_Kind_Slice_Name
| Iir_Kind_Selected_Element =>
Res := Get_Resolver (Get_Prefix (Obj));
if Res /= Null_Iir then
return Res;
end if;
when Iir_Kind_Signal_Declaration
| Iir_Kind_Interface_Signal_Declaration
| Iir_Kind_Guard_Signal_Declaration =>
null;
when Iir_Kind_Object_Alias_Declaration =>
return Get_Resolver (Get_Name (Obj));
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
return Get_Resolver (Get_Named_Entity (Obj));
when others =>
Error_Kind ("get_resolved", Obj);
end case;
Obj_Type := Get_Type (Obj);
if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then
return Get_Resolution_Indication (Obj_Type);
else
return Null_Iir;
end if;
end Get_Resolver;
-- Return TRUE iff the actual of ASSOC can be the formal.
-- ASSOC must be an association_element_by_expression.
function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean
is
Actual : Iir;
Actual_Res : Iir;
Formal_Res : Iir;
Formal_Base : Iir;
Actual_Base : Iir;
begin
-- If there is a conversion, signals types are not necessarily
-- the same, and sharing is not possible.
-- FIXME: optimize type conversions
-- (unsigned <-> signed <-> std_ulogic_vector <-> ...)
if Get_Actual_Conversion (Assoc) /= Null_Iir
or else Get_Formal_Conversion (Assoc) /= Null_Iir
then
return False;
end if;
-- Here we may assume formal and actual have the same type and the
-- same lengths. This is caught at elaboration time.
Actual := Name_To_Object (Get_Actual (Assoc));
if Actual = Null_Iir then
-- This is an expression.
return False;
end if;
Formal_Base := Get_Object_Prefix (Formal);
Actual_Base := Get_Object_Prefix (Actual);
-- If the formal is of mode IN, then it has no driving value, and its
-- effective value is the effective value of the actual.
-- Always collapse in this case.
if Get_Mode (Formal_Base) = Iir_In_Mode then
return True;
end if;
-- Otherwise, these rules are applied:
--
-- In this table, E means element, S means signal.
-- Er means the element is resolved,
-- Sr means the signal is resolved (at the signal level).
--
-- Actual
-- | E,S | Er,S | E,Sr | Er,Sr |
-- ------+-------+-------+-------+-------+
-- E,S |collap | no(3) | no(3) | no(3) |
-- ------+-------+-------+-------+-------+
-- Er,S | no(1) |if same| no(2) | no(2) |
-- Formal ------+-------+-------+-------+-------+
-- E,Sr | no(1) | no(2) |if same| no(4) |
-- ------+-------+-------+-------+-------+
-- Er,Sr | no(1) | no(2) | no(4) |if same|
-- ------+-------+-------+-------+-------+
--
-- Notes: (1): formal may have several sources.
-- (2): resolver is not the same.
-- (3): this prevents to catch several sources error in instance.
-- (4): resolver is not the same, because the types are not the
-- same.
--
-- Furthermore, signals cannot be collapsed if the kind (none, bus or
-- register) is not the same.
--
-- Default value: default value is the effective value.
-- Resolution function.
Actual_Res := Get_Resolver (Actual);
Formal_Res := Get_Resolver (Formal);
-- If the resolutions are not the same, signals cannot be collapsed.
if Actual_Res /= Formal_Res then
return False;
end if;
-- If neither the actual nor the formal is resolved, then collapsing is
-- possible.
-- (this is case ES/ES).
if Actual_Res = Null_Iir and Formal_Res = Null_Iir then
return True;
end if;
-- If the formal can have sources and is guarded, but the actual is
-- not guarded (or has not the same kind of guard), signals cannot
-- be collapsed.
if (Get_Guarded_Signal_Flag (Formal_Base)
/= Get_Guarded_Signal_Flag (Actual_Base))
or else (Get_Signal_Kind (Formal_Base)
/= Get_Signal_Kind (Actual_Base))
then
return False;
end if;
return True;
end Can_Collapse_Signals;
-- INTER_PARENT contains generics interfaces;
-- ASSOC_PARENT constains generic aspects.
function Sem_Generic_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean
is
El : Iir;
Match : Compatibility_Level;
Assoc_Chain : Iir;
Inter_Chain : Iir;
Miss : Missing_Type;
begin
-- LRM08 6.5.6.2 Generic clauses
-- If no such actual is specified for a given formal generic constant
-- (either because the formal generic is unassociated or because the
-- actual is open), and if a default expression is specified for that
-- generic, the value of this expression is the value of the generic.
-- It is an error if no actual is specified for a given formal generic
-- constant and no default expression is present in the corresponding
-- interface element.
-- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
-- true if parent is a component instantiation.
case Get_Kind (Assoc_Parent) is
when Iir_Kind_Component_Instantiation_Statement =>
-- LRM 9.6 Component Instantiation Statement
-- Each local generic (or subelement or slice thereof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- ...
-- Each local port (or subelement or slice therof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- GHDL: for a direct instantiation, follow rules of
-- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
-- The difference between 87 and 93 is simply a clarification:
-- missing association are left open, but need a default
-- expression in the formal declaration.
Miss := Missing_Generic;
when Iir_Kind_Binding_Indication =>
-- LRM 5.2.1.2 Generic map and port map aspects
Miss := Missing_Allowed;
when Iir_Kind_Block_Header =>
Miss := Missing_Generic;
when Iir_Kind_Procedure_Instantiation_Declaration
| Iir_Kind_Function_Instantiation_Declaration =>
-- LRM08 4.4
-- Each formal generic (or member thereof) shall be associated
-- at most once.
Miss := Missing_Generic;
when Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Interface_Package_Declaration
| Iir_Kind_Package_Header =>
-- LRM08 4.9
-- Each formal generic (or member thereof) shall be associated
-- at most once.
Miss := Missing_Generic;
when others =>
Error_Kind ("sem_generic_association_list", Assoc_Parent);
end case;
-- The generics
Inter_Chain := Get_Generic_Chain (Inter_Parent);
Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent);
-- Extract non-object associations, as the actual cannot be analyzed
-- as an expression.
Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain);
Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
return False;
end if;
Sem_Association_Chain
(Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match);
Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if Match = Not_Compatible then
return False;
end if;
-- LRM 5.2.1.2 Generic map and port map aspects
-- An actual associated with a formal generic map aspect must be an
-- expression or the reserved word open;
El := Assoc_Chain;
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Association_Element_By_Expression =>
Check_Read (Get_Actual (El));
when Iir_Kind_Association_Element_Open
| Iir_Kind_Association_Element_By_Individual
| Iir_Kind_Association_Element_Package
| Iir_Kind_Association_Element_Type
| Iir_Kind_Association_Element_Subprogram =>
null;
when others =>
Error_Kind ("sem_generic_association_chain(1)", El);
end case;
El := Get_Chain (El);
end loop;
return True;
end Sem_Generic_Association_Chain;
procedure Sem_Generic_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Res : Boolean;
pragma Unreferenced (Res);
begin
Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
end Sem_Generic_Association_Chain;
function Sem_Signal_Port_Association
(Assoc : Iir; Formal : Iir; Formal_Base : Iir) return Iir
is
Actual : Iir;
N_Assoc : Iir;
Prefix : Iir;
Object : Iir;
begin
Actual := Get_Actual (Assoc);
-- There has been an error, return now.
if Actual = Null_Iir then
return Assoc;
end if;
Object := Name_To_Object (Actual);
if Is_Valid (Object) and then Is_Signal_Object (Object) then
-- Port or signal.
-- Mutate to By_Name.
N_Assoc := Create_Iir (Iir_Kind_Association_Element_By_Name);
Location_Copy (N_Assoc, Assoc);
Set_Formal (N_Assoc, Get_Formal (Assoc));
Set_Chain (N_Assoc, Get_Chain (Assoc));
Set_Actual (N_Assoc, Actual);
Set_Actual_Conversion (N_Assoc, Get_Actual_Conversion (Assoc));
Set_Formal_Conversion (N_Assoc, Get_Formal_Conversion (Assoc));
Set_Whole_Association_Flag
(N_Assoc, Get_Whole_Association_Flag (Assoc));
pragma Assert (not Get_In_Formal_Flag (Assoc));
if Flag_Elocations then
declare
use Vhdl.Elocations;
begin
Create_Elocations (N_Assoc);
Set_Arrow_Location (N_Assoc, Get_Arrow_Location (Assoc));
end;
end if;
Free_Iir (Assoc);
Set_Collapse_Signal_Flag
(N_Assoc, Can_Collapse_Signals (N_Assoc, Formal));
if Get_Name_Staticness (Object) < Globally then
Error_Msg_Sem (+Actual, "actual must be a static name");
end if;
Check_Port_Association_Bounds_Restrictions
(Formal, Actual, N_Assoc);
Prefix := Get_Object_Prefix (Object);
case Get_Kind (Prefix) is
when Iir_Kind_Interface_Signal_Declaration =>
declare
P : Boolean;
pragma Unreferenced (P);
begin
P := Check_Port_Association_Mode_Restrictions
(Formal_Base, Prefix, N_Assoc);
end;
when Iir_Kind_Signal_Declaration =>
Set_Use_Flag (Prefix, True);
when others =>
-- FIXME: attributes ?
null;
end case;
return N_Assoc;
else
-- Expression.
Set_Collapse_Signal_Flag (Assoc, False);
pragma Assert (Is_Null (Get_Actual_Conversion (Assoc)));
if Flags.Vhdl_Std >= Vhdl_93 then
-- LRM93 1.1.1.2 Ports
-- Moreover, the ports of a block may be associated
-- with an expression, in order to provide these ports
-- with constant driving values; such ports must be
-- of mode in.
if Get_Mode (Formal_Base) /= Iir_In_Mode then
Error_Msg_Sem
(+Assoc, "only 'in' ports may be associated with expression");
end if;
-- Is it possible to have a globally static name that is
-- not readable ?
Check_Read (Actual);
-- LRM93 1.1.1.2 Ports
-- The actual, if an expression, must be a globally
-- static expression.
if Get_Expr_Staticness (Actual) < Globally then
if Flags.Vhdl_Std < Vhdl_08 then
-- LRM08 6.5.6.3 Port clauses
Error_Msg_Sem
(+Actual, "actual expression must be globally static");
end if;
end if;
else
Error_Msg_Sem
(+Assoc, "cannot associate ports with expression in vhdl87");
end if;
return Assoc;
end if;
end Sem_Signal_Port_Association;
-- INTER_PARENT contains ports interfaces;
-- ASSOC_PARENT constains ports map aspects.
procedure Sem_Port_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Assoc : Iir;
Prev_Assoc, N_Assoc : Iir;
Match : Compatibility_Level;
Assoc_Chain : Iir;
Inter_Chain : Iir;
Miss : Missing_Type;
Inter : Iir;
Formal : Iir;
Formal_Base : Iir;
begin
-- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
-- true if parent is a component instantiation.
case Get_Kind (Assoc_Parent) is
when Iir_Kind_Component_Instantiation_Statement =>
-- LRM 9.6 Component Instantiation Statement
-- Each local generic (or subelement or slice thereof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- ...
-- Each local port (or subelement or slice therof) must be
-- associated {VHDL87: exactly}{VHDL93: at most} once.
-- GHDL: for a direct instantiation, follow rules of
-- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
Miss := Missing_Port;
when Iir_Kind_Binding_Indication =>
-- LRM 5.2.1.2 Generic map and port map aspects
Miss := Missing_Allowed;
when Iir_Kind_Block_Header =>
-- FIXME: it is possible to have port unassociated ?
Miss := Missing_Port;
when others =>
Error_Kind ("sem_port_association_list", Assoc_Parent);
end case;
-- The ports
Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent);
Inter_Chain := Get_Port_Chain (Inter_Parent);
if AMS_Vhdl then
-- Mutate terminal associations, so that their formals are not
-- analyzed as an expression.
Assoc_Chain :=
Extract_Non_Object_Association (Assoc_Chain, Inter_Chain);
end if;
if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
return;
end if;
Sem_Association_Chain (Inter_Chain, Assoc_Chain,
True, Miss, Assoc_Parent, Match);
Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
if Match = Not_Compatible then
-- TODO: mark actual as used to avoid warnings.
return;
end if;
-- LRM 5.2.1.2 Generic map and port map aspects
-- [...]; an actual associated with a formal port in a port map aspect
-- must be a signal, an expression, or the reserved word open.
--
-- Certain restriction apply to the actual associated with a formal in
-- a port map aspect; these restrictions are described in 1.1.1.2
-- LRM93 1.1.1.2
-- The actual, if a port or signal, must be denoted by a static name.
-- The actual, if an expression, must be a globally static expression.
Assoc := Assoc_Chain;
Inter := Get_Port_Chain (Inter_Parent);
Prev_Assoc := Null_Iir;
while Assoc /= Null_Iir loop
Formal := Get_Association_Formal (Assoc, Inter);
Formal_Base := Get_Interface_Of_Formal (Formal);
case Get_Kind (Formal_Base) is
when Iir_Kind_Interface_Signal_Declaration =>
if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression
then
N_Assoc := Sem_Signal_Port_Association
(Assoc, Formal, Formal_Base);
-- Reinsert the new association (in case of mutation).
if N_Assoc /= Assoc then
if Prev_Assoc /= Null_Iir then
Set_Chain (Prev_Assoc, N_Assoc);
else
Set_Port_Map_Aspect_Chain (Assoc_Parent, N_Assoc);
end if;
Assoc := N_Assoc;
end if;
end if;
when others =>
null;
end case;
Prev_Assoc := Assoc;
Next_Association_Interface (Assoc, Inter);
end loop;
end Sem_Port_Association_Chain;
-- INTER_PARENT contains generics and ports interfaces;
-- ASSOC_PARENT constains generics and ports map aspects.
procedure Sem_Generic_Port_Association_Chain
(Inter_Parent : Iir; Assoc_Parent : Iir)
is
Res : Boolean;
pragma Unreferenced (Res);
begin
Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent);
end Sem_Generic_Port_Association_Chain;
-- LRM 1.3 Configuration Declarations.
procedure Sem_Configuration_Declaration (Decl: Iir)
is
Entity: Iir_Entity_Declaration;
Entity_Unit : Iir_Design_Unit;
begin
Xref_Decl (Decl);
Set_Is_Within_Flag (Decl, True);
-- LRM 1.3
-- The entity name identifies the name of the entity declaration that
-- defines the design entity at the apex of the design hierarchy.
Entity := Sem_Entity_Name (Decl);
if Entity = Null_Iir then
return;
end if;
Entity_Unit := Get_Design_Unit (Entity);
-- LRM 11.4
-- A primary unit whose name is referenced within a given design unit
-- must be analyzed prior to the analysis of the given design unit.
Add_Dependence (Entity_Unit);
Sem_Scopes.Add_Name (Decl);
Set_Visible_Flag (Decl, True);
-- LRM 10.1 Declarative Region
-- 2. A configuration declaration.
Open_Declarative_Region;
-- LRM93 10.2
-- In addition to the above rules, the scope of any declaration that
-- includes the end of the declarative part of a given block (whether
-- it be an external block defined by a design entity or an internal
-- block defined by a block statement) extends into a configuration
-- declaration that configures the given block.
Add_Context_Clauses (Entity_Unit);
Sem_Scopes.Add_Entity_Declarations (Entity);
Sem_Declaration_Chain (Decl);
-- GHDL: no need to check for missing subprogram bodies, since they are
-- not allowed in configuration declarations.
Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl);
Close_Declarative_Region;
Set_Is_Within_Flag (Decl, False);
end Sem_Configuration_Declaration;
-- Analyze the block specification of a block statement or of a generate
-- statement. Return the corresponding block statement, generate
-- statement body, or Null_Iir in case of error.
function Sem_Block_Specification_Of_Statement
(Block_Conf : Iir_Block_Configuration; Father : Iir) return Iir
is
Block_Spec : Iir;
Block_Name : Iir;
Block_Stmts : Iir;
Prev : Iir_Block_Configuration;
Block : Iir;
Res : Iir;
Assoc : Iir;
Clause : Iir;
Gen_Spec : Iir;
begin
Block_Spec := Get_Block_Specification (Block_Conf);
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
Block_Name := Block_Spec;
when Iir_Kind_Parenthesis_Name
| Iir_Kind_Slice_Name =>
Block_Name := Get_Prefix (Block_Spec);
when others =>
Error_Msg_Sem (+Block_Spec, "label expected");
return Null_Iir;
end case;
-- Analyze the label and generate specification.
Block_Name := Sem_Denoting_Name (Block_Name);
Block := Get_Named_Entity (Block_Name);
case Get_Kind (Block) is
when Iir_Kind_Block_Statement =>
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec,
"label does not denote a generate statement");
end if;
Set_Block_Specification (Block_Conf, Block_Name);
Prev := Get_Block_Block_Configuration (Block);
Res := Block;
when Iir_Kind_For_Generate_Statement =>
Res := Get_Generate_Statement_Body (Block);
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
Set_Block_Specification (Block_Conf, Block_Name);
when Iir_Kind_Parenthesis_Name =>
Block_Spec := Sem_Index_Specification
(Block_Spec,
Get_Type (Get_Parameter_Specification (Block)));
if Block_Spec /= Null_Iir then
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
end if;
when others =>
raise Internal_Error;
end case;
when Iir_Kind_If_Generate_Statement =>
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
-- LRM08 3.4.2 Block configuration
-- If no generate specification appears in such a block
-- configuration, then it applies to exactly one of the
-- following sets of blocks:
-- [...]
-- - The implicit block generated by the corresponding
-- generate statement, if and only if the corresponding
-- generate is an if generate statement and if the first
-- condition after IF evaluates to TRUE.
Res := Get_Generate_Statement_Body (Block);
-- LRM08 3.4.2 Block configuration
-- If the block specification of a block configuration
-- contains a generate statement label that denotes an if
-- generate statement, and if the first condition after IF
-- has an alternative label, then it is an error if the
-- generate statement label does not contain a generate
-- specification that is an alternative label.
if Get_Has_Label (Res) then
Error_Msg_Sem
(+Block_Spec,
"alternative label required in block specification");
end if;
Set_Block_Specification (Block_Conf, Block_Name);
when Iir_Kind_Parenthesis_Name =>
if Vhdl_Std < Vhdl_08 then
Error_Msg_Sem
(+Block_Spec,
"alternative label only allowed by vhdl08");
return Null_Iir;
end if;
Assoc := Get_Association_Chain (Block_Spec);
pragma Assert
(Get_Kind (Assoc)
= Iir_Kind_Association_Element_By_Expression);
Gen_Spec := Get_Actual (Assoc);
if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem
(+Gen_Spec,
"alternative label expected for if-generate");
return Null_Iir;
end if;
-- Search label.
Clause := Block;
while Clause /= Null_Iir loop
Res := Get_Generate_Statement_Body (Clause);
exit when Get_Alternative_Label (Res)
= Get_Identifier (Gen_Spec);
Clause := Get_Generate_Else_Clause (Clause);
end loop;
if Clause = Null_Iir then
Error_Msg_Sem
(+Gen_Spec,
"alternative label %i not found for if-generate",
+Gen_Spec);
return Null_Iir;
end if;
Set_Named_Entity (Block_Spec, Res);
Xref_Ref (Gen_Spec, Res);
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
when others =>
raise Internal_Error;
end case;
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
when Iir_Kind_Case_Generate_Statement =>
case Get_Kind (Block_Spec) is
when Iir_Kind_Simple_Name =>
-- LRM08 3.4.2 Block configuration
-- If no generate specification appears in such a block
-- configuration, [...]
-- GHDL: doesn't apply to case generate statement
Error_Msg_Sem
(+Block_Spec,
"missing alternative label for a case-generate");
return Null_Iir;
when Iir_Kind_Parenthesis_Name =>
Assoc := Get_Association_Chain (Block_Spec);
pragma Assert
(Get_Kind (Assoc)
= Iir_Kind_Association_Element_By_Expression);
Gen_Spec := Get_Actual (Assoc);
if Get_Kind (Gen_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem
(+Gen_Spec,
"alternative label expected for case-generate");
return Null_Iir;
end if;
-- Search label.
Clause := Get_Case_Statement_Alternative_Chain (Block);
while Clause /= Null_Iir loop
Res := Get_Associated_Block (Clause);
exit when Get_Alternative_Label (Res)
= Get_Identifier (Gen_Spec);
Clause := Get_Chain (Clause);
end loop;
if Clause = Null_Iir then
Error_Msg_Sem
(+Gen_Spec,
"alternative label %i not found for case-generate",
+Gen_Spec);
return Null_Iir;
end if;
Set_Named_Entity (Block_Spec, Res);
Xref_Ref (Gen_Spec, Res);
Set_Prefix (Block_Spec, Block_Name);
Set_Block_Specification (Block_Conf, Block_Spec);
when others =>
raise Internal_Error;
end case;
Set_Named_Entity (Block_Name, Res);
Prev := Get_Generate_Block_Configuration (Res);
when others =>
Error_Msg_Sem (+Block_Conf,
"block or generate statement label expected");
return Null_Iir;
end case;
-- LRM93 1.3.1 / LRM08 3.4.2 Block configuration
-- [...], and the label must denote a block statement or generate
-- statement that is contained immediatly within the block denoted by
-- the block specification of the containing block configuration.
Block_Stmts := Get_Concurrent_Statement_Chain
(Get_Block_From_Block_Specification
(Get_Block_Specification (Father)));
if not Is_In_Chain (Block_Stmts, Block) then
Error_Msg_Sem (+Block_Conf,
"label does not denotes an inner block statement");
return Null_Iir;
end if;
case Get_Kind (Block) is
when Iir_Kind_Block_Statement =>
-- LRM93 1.3
-- It is an error if, in a given block configuration, more than
-- one configuration item is defined for the same block [or
-- component instance].
if Prev /= Null_Iir then
Error_Msg_Sem
(+Block_Conf,
"%n was already configured at %l", (+Block, +Prev));
return Null_Iir;
end if;
Set_Block_Block_Configuration (Res, Block_Conf);
when Iir_Kind_If_Generate_Statement
| Iir_Kind_Case_Generate_Statement =>
-- LRM93 1.3
-- It is an error if, in a given block configuration, more than
-- one configuration item is defined for the same block [or
-- component instance].
if Prev /= Null_Iir then
Error_Msg_Sem
(+Block_Conf,
"%n was already configured at %l", (+Block, +Prev));
return Null_Iir;
end if;
Set_Generate_Block_Configuration (Res, Block_Conf);
when Iir_Kind_For_Generate_Statement =>
-- LRM93 1.3
-- For any name that is the label of a generate statement
-- immediately wihin a given block, one or more corresponding
-- block configuration may appear as configuration items
-- immediately within a block configuration corresponding to the
-- given block.
-- GHDL: keep them in a linked list, but don't try to detect
-- duplicate as values may not be static. FIXME: try for
-- static values only ?
Set_Prev_Block_Configuration (Block_Conf, Prev);
Set_Generate_Block_Configuration (Res, Block_Conf);
when others =>
raise Internal_Error;
end case;
return Res;
end Sem_Block_Specification_Of_Statement;
-- LRM 1.3.1 Block Configuration.
-- FATHER is the block_configuration, configuration_declaration,
-- component_configuration containing the block_configuration BLOCK_CONF.
procedure Sem_Block_Configuration
(Block_Conf : Iir_Block_Configuration; Father: Iir)
is
El : Iir;
Block : Iir;
begin
case Get_Kind (Father) is
when Iir_Kind_Configuration_Declaration =>
-- LRM93 1.3.1
-- If a block configuration appears immediately within a
-- configuration declaration, then the block specification of that
-- block configuration must be an architecture name, and that
-- architecture name must denote a design entity body whose
-- interface is defined by the entity declaration denoted by the
-- entity name of the enclosing configuration declaration.
declare
Block_Spec : Iir;
Arch : Iir_Architecture_Body;
Design: Iir_Design_Unit;
begin
Block_Spec := Get_Block_Specification (Block_Conf);
-- FIXME: handle selected name.
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec, "architecture name expected");
return;
end if;
-- LRM 10.3 rule b)
-- For an architecture body associated with a given entity
-- declaration: at the place of the block specification in a
-- block configuration for an external block whose interface
-- is defined by that entity declaration.
Design := Load_Secondary_Unit
(Get_Design_Unit (Get_Entity (Father)),
Get_Identifier (Block_Spec),
Block_Conf);
if Design = Null_Iir then
Error_Msg_Sem
(+Block_Conf, "no architecture %i", +Block_Spec);
return;
end if;
Arch := Get_Library_Unit (Design);
Set_Named_Entity (Block_Spec, Arch);
Xref_Ref (Block_Spec, Arch);
Block := Arch;
Add_Dependence (Design);
end;
when Iir_Kind_Component_Configuration =>
-- LRM93 1.3.1
-- If a block configuration appears immediately within a component
-- configuration, then the corresponding components must be
-- fully bound, the block specification of that block
-- configuration must be an architecture name, and that
-- architecture name must denote the same architecture body as
-- that to which the corresponding components are bound.
declare
Block_Spec : Iir;
Arch : Iir_Architecture_Body;
Design: Iir_Design_Unit;
Entity_Aspect : Iir;
Entity : Iir;
Comp_Arch : Iir;
begin
Entity_Aspect :=
Get_Entity_Aspect (Get_Binding_Indication (Father));
if Entity_Aspect = Null_Iir or else
Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity
then
Error_Msg_Sem
(+Block_Conf, "corresponding component not fully bound");
end if;
Block_Spec := Get_Block_Specification (Block_Conf);
-- FIXME: handle selected name.
if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
Error_Msg_Sem (+Block_Spec, "architecture name expected");
return;
end if;
Comp_Arch := Get_Architecture (Entity_Aspect);
if Comp_Arch /= Null_Iir then
pragma Assert (Get_Kind (Comp_Arch) = Iir_Kind_Simple_Name);
if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec)
then
Error_Msg_Sem
(+Block_Spec, "block specification name is different "
& "from component architecture name");
return;
end if;
end if;
Entity := Get_Entity (Entity_Aspect);
if Entity = Null_Iir then
return;
end if;
Design := Load_Secondary_Unit (Get_Design_Unit (Entity),
Get_Identifier (Block_Spec),
Block_Conf);
if Design = Null_Iir then
Error_Msg_Sem
(+Block_Conf, "no architecture %i", +Block_Spec);
return;
end if;
Add_Dependence (Design);
Arch := Get_Library_Unit (Design);
Set_Named_Entity (Block_Spec, Arch);
Xref_Ref (Block_Spec, Arch);
Block := Arch;
end;
when Iir_Kind_Block_Configuration =>
-- LRM93 1.3.1 / LRM08 3.4.2 Block configuration
-- If a block configuration appears immediately within another
-- block configuration, then the block specification of the
-- contained block configuration must be a block statement or
-- generate statement label, and the label must denote a block
-- statement or generate statement that is contained immediatly
-- within the block denoted by the block specification of the
-- containing block configuration.
Block := Sem_Block_Specification_Of_Statement (Block_Conf, Father);
if Block = Null_Iir then
return;
end if;
when others =>
Error_Kind ("sem_block_configuration", Father);
end case;
-- LRM93 10.1
-- 10. A block configuration
Sem_Scopes.Open_Scope_Extension;
-- LRM 10.3
-- In addition, any declaration that is directly visible at the end of
-- the declarative part of a given block is directly visible in a block
-- configuration that configure the given block. This rule holds unless
-- a use clause that makes a homograph of the declaration potentially
-- visible (see 10.4) appears in the corresponding configuration
-- declaration, and if the scope of that use clause encompasses all or
-- part of those configuration items. If such a use clause appears,
-- then the declaration will be directly visible within the
-- corresponding configuration items, except at hose places that fall
-- within the scope of the additional use clause. At such places,
-- neither name will be directly visible.
-- FIXME: handle use clauses.
Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block);
declare
El : Iir;
begin
El := Get_Declaration_Chain (Block_Conf);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Use_Clause =>
Sem_Use_Clause (El);
when others =>
-- Parse checks there are only use clauses.
raise Internal_Error;
end case;
El := Get_Chain (El);
end loop;
end;
-- VHDL 87: do not remove configuration specification in generate stmts.
Clear_Instantiation_Configuration (Block);
El := Get_Configuration_Item_Chain (Block_Conf);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Block_Configuration =>
Sem_Block_Configuration (El, Block_Conf);
when Iir_Kind_Component_Configuration =>
Sem_Component_Configuration (El, Block_Conf);
when others =>
Error_Kind ("sem_block_configuration(2)", El);
end case;
El := Get_Chain (El);
end loop;
Sem_Scopes.Close_Scope_Extension;
end Sem_Block_Configuration;
-- Check that incremental binding of the component configuration CONF only
-- rebinds non associated ports of each instantiations of CONFIGURED_BLOCK
-- which CONF applies to.
procedure Check_Incremental_Binding (Configured_Block : Iir; Conf : Iir)
is
Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Conf));
Inter_Chain : constant Iir := Get_Port_Chain (Comp);
Binding : constant Iir := Get_Binding_Indication (Conf);
Inst : Iir;
begin
-- Check each component instantiation of the block configured by CONF.
Inst := Get_Concurrent_Statement_Chain (Configured_Block);
while Inst /= Null_Iir loop
if Get_Kind (Inst) = Iir_Kind_Component_Instantiation_Statement
and then Get_Component_Configuration (Inst) = Conf
then
-- Check this instantiation.
declare
Primary_Binding : constant Iir := Get_Binding_Indication
(Get_Configuration_Specification (Inst));
F_Chain : constant Iir :=
Get_Port_Map_Aspect_Chain (Primary_Binding);
S_El : Iir;
S_Inter : Iir;
F_El : Iir;
Formal : Iir;
begin
S_El := Get_Port_Map_Aspect_Chain (Binding);
S_Inter := Inter_Chain;
while S_El /= Null_Iir loop
-- Find S_EL formal in F_CHAIN.
Formal := Get_Association_Interface (S_El, S_Inter);
F_El := Find_First_Association_For_Interface
(F_Chain, Inter_Chain, Formal);
if F_El /= Null_Iir
and then
Get_Kind (F_El) /= Iir_Kind_Association_Element_Open
then
Error_Msg_Sem
(+S_El,
"%n already associated in primary binding", +Formal);
end if;
Next_Association_Interface (S_El, S_Inter);
end loop;
end;
end if;
Inst := Get_Chain (Inst);
end loop;
end Check_Incremental_Binding;
-- LRM 1.3.2
procedure Sem_Component_Configuration
(Conf : Iir_Component_Configuration; Father : Iir)
is
Block : Iir;
Configured_Block : Iir;
Binding : Iir;
Entity : Iir_Design_Unit;
Comp : Iir_Component_Declaration;
Primary_Binding : Iir;
begin
-- LRM 10.1 Declarative Region
-- 11. A component configuration.
Open_Declarative_Region;
-- LRM93 10.2
-- If a component configuration appears as a configuration item
-- immediatly within a block configuration that configures a given
-- block, and the scope of a given declaration includes the end of the
-- declarative part of that block, then the scope of the given
-- declaration extends from the beginning to the end of the
-- declarative region associated with the given component configuration.
-- GHDL: this is for labels of component instantiation statements, and
-- for local ports and generics of the component.
if Get_Kind (Father) = Iir_Kind_Block_Configuration then
Configured_Block := Get_Block_Specification (Father);
pragma Assert (Get_Kind (Configured_Block) /= Iir_Kind_Design_Unit);
Configured_Block :=
Get_Block_From_Block_Specification (Configured_Block);
Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block);
else
-- Can a component configuration not be just inside a block
-- configuration ?
raise Internal_Error;
end if;
-- FIXME: this is wrong (all declarations should be considered).
Sem_Component_Specification
(Configured_Block, Conf, Primary_Binding);
Comp := Get_Named_Entity (Get_Component_Name (Conf));
if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
-- There has been an error in sem_component_specification.
-- Leave here.
Close_Declarative_Region;
return;
end if;
-- FIXME: (todo)
-- If a given component instance is unbound in the corresponding block,
-- then any explicit component configuration for that instance that does
-- not contain an explicit binding indication will contain an implicit,
-- default binding indication (see 5.2.2). Similarly, if a given
-- component instance is unbound in the corresponding block, then any
-- implicit component configuration for that instance will contain an
-- implicit, default binding indication.
Open_Declarative_Region;
Sem_Scopes.Add_Component_Declarations (Comp);
Binding := Get_Binding_Indication (Conf);
if Binding /= Null_Iir then
Sem_Binding_Indication (Binding, Conf, Primary_Binding);
if Primary_Binding /= Null_Iir then
-- LRM93 5.2.1 Binding Indication
-- It is an error if a formal port appears in the port map aspect
-- of the incremental binding indication and it is a formal
-- port that is associated with an actual other than OPEN in one
-- of the primary binding indications.
Check_Incremental_Binding (Configured_Block, Conf);
end if;
elsif Primary_Binding = Null_Iir then
-- LRM93 5.2.1
-- If the generic map aspect or port map aspect of a primary binding
-- indication is not present, then the default rules as described
-- in 5.2.2 apply.
-- Create a default binding indication.
Entity := Get_Visible_Entity_Declaration (Comp);
Binding := Sem_Create_Default_Binding_Indication
(Comp, Entity, Conf, False, False);
if Binding /= Null_Iir then
-- Remap to defaults.
Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding));
Set_Entity_Aspect (Binding, Null_Iir);
Set_Binding_Indication (Conf, Binding);
end if;
end if;
Close_Declarative_Region;
-- External block.
Block := Get_Block_Configuration (Conf);
if Block /= Null_Iir and then Binding /= Null_Iir then
Sem_Block_Configuration (Block, Conf);
end if;
Close_Declarative_Region;
end Sem_Component_Configuration;
function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean
is
El_Left, El_Right : Iir;
begin
if Left = Right then
return True;
end if;
El_Left := Left;
El_Right := Right;
loop
if El_Left = Null_Iir and El_Right = Null_Iir then
return True;
end if;
if El_Left = Null_Iir or El_Right = Null_Iir then
return False;
end if;
if not Are_Trees_Equal (El_Left, El_Right) then
return False;
end if;
El_Left := Get_Chain (El_Left);
El_Right := Get_Chain (El_Right);
end loop;
end Are_Trees_Chain_Equal;
function Are_Trees_List_Equal (Left, Right : Iir_Flist) return Boolean
is
El_Left, El_Right : Iir;
begin
pragma Assert (Flist_Last (Left) = Flist_Last (Right));
for I in Flist_First .. Flist_Last (Left) loop
El_Left := Get_Nth_Element (Left, I);
El_Right := Get_Nth_Element (Right, I);
if not Are_Trees_Equal (El_Left, El_Right) then
return False;
end if;
end loop;
return True;
end Are_Trees_List_Equal;
-- Return TRUE iff LEFT and RIGHT are (in depth) equal.
-- This corresponds to conformance rules, LRM93 2.7
function Are_Trees_Equal (Left, Right : Iir) return Boolean
is
El_Left, El_Right : Iir;
begin
-- Short-cut to speed up.
if Left = Right then
return True;
end if;
-- Handle null_iir.
if Left = Null_Iir or Right = Null_Iir then
-- Note: LEFT *xor* RIGHT is null_iir.
return False;
end if;
-- LRM 2.7 Conformance Rules
-- A simple name can be replaced by an expanded name in which this
-- simple name is the selector, if and only if at both places the
-- meaning of the simple name is given by the same declaration.
case Get_Kind (Left) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
case Get_Kind (Right) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
return Are_Trees_Equal (Get_Named_Entity (Left),
Get_Named_Entity (Right));
when others =>
return False;
end case;
when others =>
null;
end case;
-- If nodes are not of the same kind, then they are not equals!
if Get_Kind (Left) /= Get_Kind (Right) then
return False;
end if;
case Get_Kind (Left) is
when Iir_Kind_Procedure_Declaration =>
return Are_Trees_Chain_Equal
(Get_Interface_Declaration_Chain (Left),
Get_Interface_Declaration_Chain (Right));
when Iir_Kind_Function_Declaration =>
if not Are_Trees_Equal (Get_Return_Type (Left),
Get_Return_Type (Right))
then
return False;
end if;
if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then
return False;
end if;
if not Are_Trees_Chain_Equal
(Get_Interface_Declaration_Chain (Left),
Get_Interface_Declaration_Chain (Right))
then
return False;
end if;
return True;
when Iir_Kind_Interface_Constant_Declaration
| Iir_Kind_Interface_Variable_Declaration
| Iir_Kind_Interface_Signal_Declaration
| Iir_Kind_Interface_File_Declaration =>
if Get_Identifier (Left) /= Get_Identifier (Right) then
return False;
end if;
if Get_Has_Mode (Left) /= Get_Has_Mode (Right)
or else Get_Has_Class (Left) /= Get_Has_Class (Right)
or else (Get_Has_Identifier_List (Left)
/= Get_Has_Identifier_List (Right))
or else Get_Mode (Left) /= Get_Mode (Right)
then
return False;
end if;
if not Are_Trees_Equal (Get_Subtype_Indication (Left),
Get_Subtype_Indication (Right))
then
return False;
end if;
El_Left := Get_Default_Value (Left);
El_Right := Get_Default_Value (Right);
if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then
return False;
end if;
if El_Left /= Null_Iir
and then Are_Trees_Equal (El_Left, El_Right) = False
then
return False;
end if;
return True;
when Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Enumeration_Subtype_Definition
| Iir_Kind_Floating_Subtype_Definition
| Iir_Kind_Physical_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then
return False;
end if;
if not Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
then
return False;
end if;
if Are_Trees_Equal (Get_Range_Constraint (Left),
Get_Range_Constraint (Right)) = False
then
return False;
end if;
return True;
when Iir_Kind_Array_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
if not Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
then
return False;
end if;
if not Are_Trees_List_Equal (Get_Index_Subtype_List (Left),
Get_Index_Subtype_List (Right))
then
return False;
end if;
return True;
when Iir_Kind_Record_Subtype_Definition =>
if Get_Base_Type (Left) /= Get_Base_Type (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Resolution_Indication (Left),
Get_Resolution_Indication (Right))
and then
Are_Trees_List_Equal (Get_Elements_Declaration_List (Left),
Get_Elements_Declaration_List (Right));
when Iir_Kind_Integer_Literal =>
if Get_Value (Left) /= Get_Value (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Enumeration_Literal =>
if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Physical_Int_Literal =>
if Get_Value (Left) /= Get_Value (Right)
or else not Are_Trees_Equal (Get_Unit_Name (Left),
Get_Unit_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Physical_Fp_Literal =>
if Get_Fp_Value (Left) /= Get_Fp_Value (Right)
or else not Are_Trees_Equal (Get_Unit_Name (Left),
Get_Unit_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kind_Unit_Declaration =>
return Left = Right;
when Iir_Kind_Floating_Point_Literal =>
if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then
return False;
end if;
return Are_Trees_Equal (Get_Literal_Origin (Left),
Get_Literal_Origin (Right));
when Iir_Kinds_Dyadic_Operator =>
return Are_Trees_Equal (Get_Left (Left), Get_Left (Right))
and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right));
when Iir_Kinds_Monadic_Operator =>
return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right));
when Iir_Kind_Function_Call =>
return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right))
and then
Are_Trees_Chain_Equal (Get_Parameter_Association_Chain (Left),
Get_Parameter_Association_Chain (Right));
when Iir_Kind_Association_Element_By_Expression =>
return Are_Trees_Equal (Get_Actual (Left), Get_Actual (Right))
and then Are_Trees_Equal (Get_Formal (Left), Get_Formal (Right))
and then Are_Trees_Equal (Get_Actual_Conversion (Left),
Get_Actual_Conversion (Right))
and then Are_Trees_Equal (Get_Formal_Conversion (Left),
Get_Formal_Conversion (Right));
when Iir_Kind_Type_Conversion =>
return Are_Trees_Equal (Get_Type_Mark (Left),
Get_Type_Mark (Right))
and then
Are_Trees_Equal (Get_Expression (Left),
Get_Expression (Right));
when Iir_Kind_Indexed_Name =>
return Are_Trees_Equal (Get_Prefix (Left),
Get_Prefix (Right))
and then
Are_Trees_List_Equal (Get_Index_List (Left),
Get_Index_List (Right));
when Iir_Kind_Slice_Name =>
return Are_Trees_Equal (Get_Prefix (Left),
Get_Prefix (Right))
and then Are_Trees_Equal (Get_Suffix (Left),
Get_Suffix (Right));
when Iir_Kind_Selected_Element =>
return Are_Trees_Equal (Get_Prefix (Left),
Get_Prefix (Right))
and then Get_Identifier (Left) = Get_Identifier (Right);
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Record_Type_Definition
| Iir_Kind_Array_Type_Definition
| Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_File_Type_Definition =>
return Left = Right;
when Iir_Kind_Range_Expression =>
if Get_Type (Left) /= Get_Type (Right)
or else Get_Direction (Left) /= Get_Direction (Right)
then
return False;
end if;
return Are_Trees_Equal (Get_Left_Limit (Left),
Get_Left_Limit (Right))
and then Are_Trees_Equal (Get_Right_Limit (Left),
Get_Right_Limit (Right));
when Iir_Kind_High_Type_Attribute
| Iir_Kind_Low_Type_Attribute
| Iir_Kind_Left_Type_Attribute
| Iir_Kind_Right_Type_Attribute
| Iir_Kind_Ascending_Type_Attribute =>
return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right));
when Iir_Kind_Length_Array_Attribute
| Iir_Kind_Left_Array_Attribute
| Iir_Kind_Right_Array_Attribute
| Iir_Kind_Low_Array_Attribute
| Iir_Kind_High_Array_Attribute
| Iir_Kind_Ascending_Array_Attribute =>
return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right))
and then
Are_Trees_Equal (Get_Parameter (Left), Get_Parameter (Right));
when Iir_Kind_String_Literal8 =>
if Get_Bit_String_Base (Left) /= Get_Bit_String_Base (Right) then
return False;
end if;
declare
use Str_Table;
Len : constant Nat32 := Get_String_Length (Left);
L_Id : constant String8_Id := Get_String8_Id (Left);
R_Id : constant String8_Id := Get_String8_Id (Right);
begin
if Get_String_Length (Right) /= Len then
return False;
end if;
for I in 1 .. Len loop
if Element_String8 (L_Id, I) /= Element_String8 (R_Id, I)
then
return False;
end if;
end loop;
return True;
end;
when Iir_Kind_Aggregate =>
if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then
return False;
end if;
return Are_Trees_Chain_Equal
(Get_Association_Choices_Chain (Left),
Get_Association_Choices_Chain (Right));
when Iir_Kind_Choice_By_None
| Iir_Kind_Choice_By_Others =>
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Name =>
if not Are_Trees_Equal (Get_Choice_Name (Left),
Get_Choice_Name (Right))
then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Expression =>
if not Are_Trees_Equal (Get_Choice_Expression (Left),
Get_Choice_Expression (Right)) then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Choice_By_Range =>
if not Are_Trees_Equal (Get_Choice_Range (Left),
Get_Choice_Range (Right)) then
return False;
end if;
return Are_Trees_Equal (Get_Associated_Expr (Left),
Get_Associated_Expr (Right));
when Iir_Kind_Character_Literal =>
return Are_Trees_Equal (Get_Named_Entity (Left),
Get_Named_Entity (Right));
when Iir_Kind_Allocator_By_Subtype =>
return Are_Trees_Equal (Get_Subtype_Indication (Left),
Get_Subtype_Indication (Right));
when Iir_Kind_Allocator_By_Expression =>
return Are_Trees_Equal (Get_Expression (Left),
Get_Expression (Right));
when others =>
Error_Kind ("are_trees_equal", Left);
end case;
end Are_Trees_Equal;
-- LRM 2.7 Conformance Rules.
procedure Check_Conformance_Rules (Subprg, Spec: Iir) is
begin
if not Are_Trees_Equal (Subprg, Spec) then
-- FIXME: should explain why it does not conform ?
Error_Msg_Sem
(+Subprg, "body of %n does not conform with specification at %l",
(+Subprg, +Spec));
end if;
end Check_Conformance_Rules;
-- Return the specification corresponding to a declaration DECL, or
-- null_Iir if none.
-- FIXME: respect rules of LRM93 2.7
function Find_Subprogram_Specification (Decl: Iir) return Iir
is
Interpretation : Name_Interpretation_Type;
Decl1: Iir;
Hash : Iir_Int32;
begin
Hash := Get_Subprogram_Hash (Decl);
Interpretation := Get_Interpretation (Get_Identifier (Decl));
while Valid_Interpretation (Interpretation) loop
if not Is_In_Current_Declarative_Region (Interpretation) then
-- The declaration does not belong to the current declarative
-- region, neither will the following one. So, we do not found
-- it.
return Null_Iir;
end if;
Decl1 := Get_Declaration (Interpretation);
-- Should be sure DECL1 and DECL belongs to the same declarative
-- region, ie DECL1 was not made visible via a USE clause.
--
-- Also, only check for explicitly subprograms (and not
-- implicit one).
if not Is_Implicit_Subprogram (Decl1)
and then Get_Kind (Decl1) in Iir_Kinds_Subprogram_Declaration
and then not Is_Potentially_Visible (Interpretation)
and then Get_Subprogram_Hash (Decl1) = Hash
and then Is_Same_Profile (Decl, Decl1)
then
return Decl1;
end if;
Interpretation := Get_Next_Interpretation (Interpretation);
end loop;
return Null_Iir;
end Find_Subprogram_Specification;
procedure Set_Subprogram_Overload_Number (Decl : Iir)
is
Id : constant Name_Id := Get_Identifier (Decl);
Inter : Name_Interpretation_Type;
Prev : Iir;
Num : Iir_Int32;
begin
Inter := Get_Interpretation (Id);
while Valid_Interpretation (Inter)
and then Is_In_Current_Declarative_Region (Inter)
loop
-- There is a previous declaration with the same name in the
-- current declarative region.
Prev := Get_Declaration (Inter);
case Get_Kind (Prev) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
if Is_Implicit_Subprogram (Prev) then
-- Implicit declarations aren't taken into account (as they
-- are mangled differently).
Inter := Get_Next_Interpretation (Inter);
else
-- The previous declaration is a user subprogram.
Num := Get_Overload_Number (Prev) + 1;
if Num = 1
and then Get_Parent (Prev) = Get_Parent (Decl)
then
-- The previous was not (yet) overloaded. Mark it as
-- overloaded.
-- Do not mark it if it is not in the same declarative
-- part (ie, do not change a subprogram declaration in
-- the package while analyzing the body).
Set_Overload_Number (Prev, 1);
Num := 2;
end if;
Set_Overload_Number (Decl, Num);
return;
end if;
when Iir_Kind_Enumeration_Literal =>
-- Enumeration literal are ignored for overload number.
Inter := Get_Next_Interpretation (Inter);
when Iir_Kind_Non_Object_Alias_Declaration =>
-- Subprogram aliases aren't considered, just skip them.
-- (No subprogram is created by an alias).
Inter := Get_Next_Interpretation (Inter);
when others =>
-- Case of user error: redefinition of an identifier.
-- Error message is generated by sem_scope.
Set_Overload_Number (Decl, 0);
return;
end case;
end loop;
-- No previous declaration in the current declarative region.
Set_Overload_Number (Decl, 0);
end Set_Subprogram_Overload_Number;
-- Check requirements on number of interfaces for subprogram specification
-- SUBPRG. Requirements only concern operators, and are defined in
-- LRM 2.3.1
procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir)
is
use Std_Names;
Nbr_Interfaces : Natural;
Is_Method : Boolean;
begin
Nbr_Interfaces := Vhdl.Nodes_Utils.Get_Chain_Length
(Get_Interface_Declaration_Chain (Subprg));
-- For vhdl-02, the protected variable is an implicit parameter.
if Flags.Vhdl_Std >= Vhdl_02
and then Is_Subprogram_Method (Subprg)
then
Nbr_Interfaces := Nbr_Interfaces + 1;
else
Is_Method := False;
end if;
case Id is
when Name_Abs
| Name_Not =>
-- LRM93 2.3.1
-- The subprogram specification of a unary operator must have a
-- single parameter.
-- LRM02 2.3.1
-- ..., unless the subprogram specification is a method (see
-- 3.5.1) of a protected type. In this latter case, the
-- subprogram specification must have no parameters.
if Nbr_Interfaces = 1 then
return;
end if;
Error_Msg_Sem
(+Subprg, "unary operator must have a single parameter");
when Name_Mod
| Name_Rem
| Name_Op_Mul
| Name_Op_Div
| Name_Relational_Operators
| Name_Op_Concatenation
| Name_Shift_Operators
| Name_Op_Exp =>
-- LRM93 2.3.1
-- The subprogram specification of a binary operator must have
-- two parameters.
-- LRM02 2.3.1
-- ..., unless the subprogram specification is a method of a
-- protected type, in which case, the subprogram specification
-- must have a single parameter.
if Nbr_Interfaces = 2 then
return;
end if;
Error_Msg_Sem
(+Subprg, "binary operators must have two parameters");
when Name_Logical_Operators
| Name_Xnor =>
-- LRM08 4.5.2 Operator overloading
-- For each of the "+", "-", "and", "or", "xor", "nand", "nor"
-- and "xnor", overloading is allowed both as a unary operator
-- and as a binary operator.
if Nbr_Interfaces = 2 then
return;
end if;
if Nbr_Interfaces = 1 then
if Vhdl_Std >= Vhdl_08 then
return;
end if;
Error_Msg_Sem
(+Subprg,
"logical operators must have two parameters before vhdl08");
else
Error_Msg_Sem
(+Subprg, "logical operators must have two parameters");
end if;
when Name_Op_Plus
| Name_Op_Minus =>
-- LRM93 2.3.1
-- For each of the operators "+" and "-", overloading is allowed
-- both as a unary operator and as a binary operator.
if Nbr_Interfaces in 1 .. 2 then
return;
end if;
Error_Msg_Sem
(+Subprg,
"""+"" and ""-"" operators must have 1 or 2 parameters");
when others =>
return;
end case;
if Is_Method then
Error_Msg_Sem
(+Subprg,
" (the protected object is an implicit parameter of methods)");
end if;
end Check_Operator_Requirements;
procedure Sem_Subprogram_Specification (Subprg: Iir)
is
Interface_Chain : Iir;
Return_Type : Iir;
begin
-- LRM 10.1 Declarative Region
-- 3. A subprogram declaration, together with the corresponding
-- subprogram body.
Open_Declarative_Region;
-- Sem generics.
if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then
Sem_Interface_Chain
(Get_Generic_Chain (Subprg), Generic_Interface_List);
end if;
-- Sem interfaces.
Interface_Chain := Get_Interface_Declaration_Chain (Subprg);
case Get_Kind (Subprg) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Interface_Function_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Function_Parameter_Interface_List);
Return_Type := Get_Return_Type_Mark (Subprg);
Return_Type := Sem_Type_Mark (Return_Type);
Set_Return_Type_Mark (Subprg, Return_Type);
Return_Type := Get_Type (Return_Type);
Set_Return_Type (Subprg, Return_Type);
Set_All_Sensitized_State (Subprg, Unknown);
-- LRM08 4.2 Subprogram declarations
-- It is an error if the result subtype of a function denotes
-- either a file type or a protected type. Moreover, it is an
-- error if the result subtype of a pure function denotes an
-- access type or a subtype that has a subelement of an access
-- type.
-- GHDL: this was added by VHDL 2008, but vital packages don't
-- follow that rule. So, it is not retroactive.
case Get_Kind (Return_Type) is
when Iir_Kind_File_Type_Definition =>
Error_Msg_Sem
(+Subprg, "result subtype cannot denote a file type");
when Iir_Kind_Protected_Type_Declaration =>
Error_Msg_Sem
(+Subprg, "result subtype cannot denote a protected type");
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Access_Subtype_Definition =>
if Vhdl_Std >= Vhdl_08
and then Get_Pure_Flag (Subprg)
then
Error_Msg_Sem_Relaxed
(Subprg, Warnid_Pure,
"result subtype of a pure function cannot denote an"
& " access type");
end if;
when others =>
if Vhdl_Std >= Vhdl_08
and then not Get_Signal_Type_Flag (Return_Type)
and then Get_Pure_Flag (Subprg)
then
Error_Msg_Sem_Relaxed
(Subprg, Warnid_Pure,
"result subtype of a pure function cannot have"
& " access subelements");
end if;
end case;
when Iir_Kind_Interface_Procedure_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Procedure_Parameter_Interface_List);
when Iir_Kind_Procedure_Declaration =>
Sem_Interface_Chain
(Interface_Chain, Procedure_Parameter_Interface_List);
-- Unless the body is analyzed, the procedure purity is unknown.
Set_Purity_State (Subprg, Unknown);
-- Check if the procedure is passive.
Set_Passive_Flag (Subprg, True);
Set_All_Sensitized_State (Subprg, Unknown);
declare
Inter : Iir;
begin
Inter := Interface_Chain;
while Inter /= Null_Iir loop
if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
and then Get_Mode (Inter) /= Iir_In_Mode
then
-- There is a driver for this signal interface.
Set_Passive_Flag (Subprg, False);
exit;
end if;
Inter := Get_Chain (Inter);
end loop;
end;
-- Mark the procedure as suspendable, unless in a std or
-- most ieee packages.
-- This is a minor optimization.
declare
Lib : constant Iir :=
Get_Library (Get_Design_File (Get_Current_Design_Unit));
begin
if Lib = Libraries.Std_Library then
-- No procedures in std have a wait statement.
null;
elsif Get_Identifier (Lib) = Std_Names.Name_Ieee then
-- Package ieee.vital_primitives has wait statements.
declare
Unit : constant Iir :=
Get_Library_Unit (Get_Current_Design_Unit);
Unit_Id : constant Name_Id := Get_Identifier (Unit);
begin
if Unit_Id = Std_Names.Name_VITAL_Primitives then
Set_Suspend_Flag (Subprg, True);
end if;
end;
else
-- User procedures may have wait statements.
Set_Suspend_Flag (Subprg, True);
end if;
end;
when others =>
Error_Kind ("sem_subprogram_declaration", Subprg);
end case;
Check_Operator_Requirements (Get_Identifier (Subprg), Subprg);
Sem_Utils.Compute_Subprogram_Hash (Subprg);
-- The specification has been analyzed, close the declarative region
-- now.
Close_Declarative_Region;
end Sem_Subprogram_Specification;
-- LRM 2.1 Subprogram Declarations.
procedure Sem_Subprogram_Declaration (Subprg: Iir)
is
Parent : constant Iir := Get_Parent (Subprg);
Spec: Iir;
Subprg_Body : Iir;
begin
-- Set depth.
case Get_Kind (Parent) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
raise Internal_Error;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
Set_Subprogram_Depth
(Subprg,
Get_Subprogram_Depth
(Get_Subprogram_Specification (Parent)) + 1);
when others =>
-- FIXME: protected type ?
Set_Subprogram_Depth (Subprg, 0);
end case;
Sem_Subprogram_Specification (Subprg);
-- Look if there is an associated body (the next node).
Subprg_Body := Get_Chain (Subprg);
if Subprg_Body /= Null_Iir
and then Get_Kind (Subprg_Body) in Iir_Kinds_Subprogram_Body
then
Spec := Find_Subprogram_Specification (Subprg);
else
Spec := Null_Iir;
end if;
if Spec /= Null_Iir then
-- SUBPRG is the body of the specification SPEC.
if Get_Subprogram_Body (Spec) /= Null_Iir then
Error_Msg_Sem (+Subprg, "%n body already defined at %l",
(+Spec, +Get_Subprogram_Body (Spec)));
-- Kill warning.
Set_Use_Flag (Subprg, True);
else
Check_Conformance_Rules (Subprg, Spec);
Xref_Body (Subprg, Spec);
Set_Subprogram_Body (Subprg, Subprg_Body);
Set_Subprogram_Specification (Subprg_Body, Spec);
Set_Subprogram_Body (Spec, Subprg_Body);
end if;
else
-- Forward declaration or specification followed by body.
Set_Subprogram_Overload_Number (Subprg);
Sem_Scopes.Add_Name (Subprg);
Name_Visible (Subprg);
Xref_Decl (Subprg);
end if;
end Sem_Subprogram_Declaration;
procedure Add_Analysis_Checks_List (El : Iir)
is
Design : constant Iir := Get_Current_Design_Unit;
List : Iir_List;
begin
List := Get_Analysis_Checks_List (Design);
if List = Null_Iir_List then
List := Create_Iir_List;
Set_Analysis_Checks_List (Design, List);
end if;
Add_Element (List, El);
end Add_Analysis_Checks_List;
procedure Sem_Subprogram_Body (Subprg : Iir)
is
Spec : constant Iir := Get_Subprogram_Specification (Subprg);
Warn_Hide_Enabled : constant Boolean := Is_Warning_Enabled (Warnid_Hide);
El : Iir;
begin
Set_Impure_Depth (Subprg, Iir_Depth_Pure);
-- LRM 10.1 Declarative regions
-- 3. A subprogram declaration, together with the corresponding
-- subprogram body.
Open_Declarative_Region;
Set_Is_Within_Flag (Spec, True);
-- Add the interface names into the current declarative region.
-- (Do not emit warnings for hiding, they were already emitted during
-- analysis of the subprogram spec).
Enable_Warning (Warnid_Hide, False);
El := Get_Interface_Declaration_Chain (Spec);
while El /= Null_Iir loop
Add_Name (El, Get_Identifier (El), False);
if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then
Set_Has_Active_Flag (El, False);
end if;
El := Get_Chain (El);
end loop;
Enable_Warning (Warnid_Hide, Warn_Hide_Enabled);
-- For vhdl-19, handle return identifier.
if Get_Kind (Spec) = Iir_Kind_Function_Declaration then
declare
Ret : constant Iir := Get_Return_Identifier (Spec);
Ret_Type : Iir;
begin
if Ret /= Null_Iir then
Xrefs.Xref_Decl (Ret);
Set_Visible_Flag (Ret, True);
Ret_Type := Get_Type (Spec);
Ret_Type := Sem_Types.Build_Constrained_Subtype (Ret_Type, Ret);
Set_Type (Ret, Ret_Type);
Add_Name (Ret, Get_Identifier (Ret), False);
end if;
end;
end if;
Sem_Sequential_Statements (Spec, Subprg);
Set_Is_Within_Flag (Spec, False);
Close_Declarative_Region;
case Get_Kind (Spec) is
when Iir_Kind_Procedure_Declaration =>
if Get_Suspend_Flag (Subprg)
and then not Get_Suspend_Flag (Spec)
then
-- Incoherence: procedures declared in std library are not
-- expected to suspend. This is an internal check.
Error_Msg_Sem (+Subprg, "unexpected suspendable procedure");
end if;
-- Update purity state of procedure if there are no callees.
case Get_Purity_State (Spec) is
when Pure
| Maybe_Impure =>
-- We can't know this yet.
raise Internal_Error;
when Impure =>
null;
when Unknown =>
if Get_Callees_List (Subprg) = Null_Iir_List then
-- Since there are no callees, purity state can
-- be updated.
if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then
Set_Purity_State (Spec, Pure);
else
Set_Purity_State (Spec, Maybe_Impure);
end if;
end if;
end case;
-- Update wait state if the state of all callees is known.
if Get_Wait_State (Spec) = Unknown then
declare
Callees : constant Iir_List := Get_Callees_List (Subprg);
Callees_It : List_Iterator;
Callee : Iir;
State : Tri_State_Type;
begin
-- Per default, has no wait.
Set_Wait_State (Spec, False);
Callees_It := List_Iterate_Safe (Callees);
while Is_Valid (Callees_It) loop
Callee := Get_Element (Callees_It);
case Get_Kind (Callee) is
when Iir_Kind_Function_Declaration =>
null;
when Iir_Kind_Procedure_Declaration =>
State := Get_Wait_State (Callee);
case State is
when False =>
null;
when Unknown =>
-- Yet unknown, but can be TRUE.
Set_Wait_State (Spec, Unknown);
when True =>
-- Can this happen ?
raise Internal_Error;
--Set_Wait_State (Spec, True);
--exit;
end case;
when others =>
Error_Kind ("sem_subprogram_body(2)", Callee);
end case;
Next (Callees_It);
end loop;
end;
end if;
-- Do not add to Analysis_Checks_List as procedures can't
-- generate purity/wait/all-sensitized errors by themselves.
when Iir_Kind_Function_Declaration =>
if Get_Callees_List (Subprg) /= Null_Iir_List then
-- Purity calls to be checked later.
-- No wait statements in procedures called.
Add_Analysis_Checks_List (Spec);
end if;
when others =>
Error_Kind ("sem_subprogram_body", Spec);
end case;
-- Set All_Sensitized_State in trivial cases.
if Get_All_Sensitized_State (Spec) = Unknown
and then Get_Callees_List (Subprg) = Null_Iir_List
then
Set_All_Sensitized_State (Spec, No_Signal);
end if;
end Sem_Subprogram_Body;
function Sem_Uninstantiated_Subprogram_Name (Decl : Iir) return Iir
is
Name : Iir;
Subprg : Iir;
begin
Name := Get_Uninstantiated_Subprogram_Name (Decl);
if Get_Kind (Name) = Iir_Kind_Signature then
-- TODO
raise Internal_Error;
end if;
Name := Sem_Denoting_Name (Name);
Set_Uninstantiated_Subprogram_Name (Decl, Name);
Subprg := Get_Named_Entity (Name);
if Is_Error (Subprg) then
return Subprg;
end if;
if Is_Overload_List (Subprg) then
-- TODO
raise Internal_Error;
end if;
if Get_Kind (Subprg) not in Iir_Kinds_Subprogram_Declaration then
Error_Class_Match (Name, "package");
return Create_Error (Subprg);
end if;
case Get_Kind (Decl) is
when Iir_Kind_Procedure_Instantiation_Declaration =>
if Get_Kind (Subprg) /= Iir_Kind_Procedure_Declaration then
Error_Msg_Sem
(+Name,
"a procedure instantiation cannot instantiate %i", +Subprg);
return Create_Error (Subprg);
end if;
when Iir_Kind_Function_Instantiation_Declaration =>
if Get_Kind (Subprg) /= Iir_Kind_Function_Declaration then
Error_Msg_Sem
(+Name,
"a function instantiation cannot instantiate %i", +Subprg);
return Create_Error (Subprg);
end if;
when others =>
raise Internal_Error;
end case;
if not Is_Uninstantiated_Subprogram (Subprg) then
Error_Msg_Sem
(+Name, "%n is not an uninstantiated subprogram", +Subprg);
return Create_Error (Subprg);
end if;
return Subprg;
end Sem_Uninstantiated_Subprogram_Name;
procedure Sem_Subprogram_Instantiation_Declaration (Decl : Iir)
is
Subprg : Iir;
begin
Xref_Decl (Decl);
Subprg := Sem_Uninstantiated_Subprogram_Name (Decl);
if Subprg = Null_Iir or Is_Error (Subprg) then
-- What could be done ?
return;
end if;
-- LRM08 4.4 Subprogram instantiation declarations
-- The generic map aspect, if present, optionally associates a single
-- actual with each formal generic (or member thereof) in the
-- corresponding subprogram declaration. Each formal generic (of member
-- thereof) shall be associated at most once.
if not Sem_Generic_Association_Chain (Subprg, Decl) then
-- FIXME: stop analysis here ?
return;
end if;
-- Create the interface parameters.
Sem_Inst.Instantiate_Subprogram_Declaration (Decl, Subprg);
-- Add DECL. Must be done after parameters creation to handle
-- homographs.
Sem_Scopes.Add_Name (Decl);
Set_Visible_Flag (Decl, True);
end Sem_Subprogram_Instantiation_Declaration;
-- Return the subprogram body of SPEC. If there is no body, and if SPEC
-- is an instance, returns the body of the generic specification but only
-- if known.
function Get_Subprogram_Body_Or_Generic (Spec : Iir) return Iir
is
Bod : Iir;
Orig : Iir;
begin
Bod := Get_Subprogram_Body (Spec);
if Bod /= Null_Iir then
return Bod;
end if;
Orig := Sem_Inst.Get_Origin (Spec);
if Orig = Null_Iir then
return Null_Iir;
end if;
return Get_Subprogram_Body (Orig);
end Get_Subprogram_Body_Or_Generic;
-- Status of Update_And_Check_Pure_Wait.
type Update_Pure_Status is
(
-- The purity/wait/all-sensitized are computed and known.
Update_Pure_Done,
-- A missing body prevents from computing the purity/wait/all-sensitized
Update_Pure_Missing,
-- Purity/wait/all-sensitized is unknown (recursion).
Update_Pure_Unknown
);
function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status
is
procedure Error_Wait (Caller : Iir; Callee : Iir) is
begin
Report_Start_Group;
Error_Msg_Sem
(+Caller, "%n must not contain wait statement, but calls", +Caller);
Error_Msg_Sem
(+Callee, "%n which has (indirectly) a wait statement", +Callee);
Report_End_Group;
end Error_Wait;
-- Kind of subprg.
type Caller_Kind is (K_Function, K_Process, K_Procedure);
Kind : Caller_Kind;
Callees_List : Iir_List;
Callees_List_Holder : Iir;
Callees_It : List_Iterator;
Callee : Iir;
Callee_Bod : Iir;
Subprg_Depth : Iir_Int32;
Subprg_Bod : Iir;
-- Current purity depth of SUBPRG.
Depth : Iir_Int32;
Depth_Callee : Iir_Int32;
Has_Wait_Errors : Boolean := False;
New_List : Iir_List;
Res, Res1 : Update_Pure_Status;
begin
case Get_Kind (Subprg) is
when Iir_Kind_Function_Declaration =>
Kind := K_Function;
Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg);
if Subprg_Bod = Null_Iir then
return Update_Pure_Missing;
end if;
Subprg_Depth := Get_Subprogram_Depth (Subprg);
Callees_List_Holder := Subprg_Bod;
if Get_Pure_Flag (Subprg) then
Depth := Iir_Depth_Pure;
else
Depth := Iir_Depth_Impure;
end if;
when Iir_Kind_Procedure_Declaration =>
Kind := K_Procedure;
Subprg_Bod := Get_Subprogram_Body_Or_Generic (Subprg);
if Subprg_Bod = Null_Iir then
return Update_Pure_Missing;
end if;
if Get_Purity_State (Subprg) = Impure
and then Get_Wait_State (Subprg) /= Unknown
and then Get_All_Sensitized_State (Subprg) /= Unknown
then
-- No need to go further.
if Get_All_Sensitized_State (Subprg) = No_Signal
or else Vhdl_Std < Vhdl_08
then
Callees_List := Get_Callees_List (Subprg_Bod);
Destroy_Iir_List (Callees_List);
Set_Callees_List (Subprg_Bod, Null_Iir_List);
end if;
return Update_Pure_Done;
end if;
Subprg_Depth := Get_Subprogram_Depth (Subprg);
Depth := Get_Impure_Depth (Subprg_Bod);
Callees_List_Holder := Subprg_Bod;
when Iir_Kind_Sensitized_Process_Statement =>
Kind := K_Process;
Subprg_Bod := Null_Iir;
Subprg_Depth := Iir_Depth_Top;
Depth := Iir_Depth_Impure;
Callees_List_Holder := Subprg;
when others =>
Error_Kind ("update_and_check_pure_wait(1)", Subprg);
end case;
-- If the subprogram has no callee list, there is nothing to do.
Callees_List := Get_Callees_List (Callees_List_Holder);
if Callees_List = Null_Iir_List then
-- There are two reasons why a callees_list is null:
-- * either because SUBPRG does not call any procedure
-- in this case, the status are already known and we should have
-- returned in the above case.
-- * or because of a recursion
-- in this case the status are still unknown here.
return Update_Pure_Unknown;
end if;
-- By default we don't know the status.
Res := Update_Pure_Unknown;
-- This subprogram is being considered.
-- To avoid infinite loop, suppress its callees list.
Set_Callees_List (Callees_List_Holder, Null_Iir_List);
-- First loop: check without recursion.
-- Second loop: recurse if necessary.
for J in 0 .. 1 loop
New_List := Create_Iir_List;
Callees_It := List_Iterate (Callees_List);
while Is_Valid (Callees_It) loop
Callee := Get_Element (Callees_It);
-- Note:
-- Pure functions should not be in the list.
-- Impure functions must have directly set Purity_State.
-- The body of subprograms may not be set for instances.
-- Use the body from the generic (if any).
-- This is meaningful for non macro-expanded package interface,
-- because there is no associated body and because the call
-- tree is known (if there were an interface subprogram, it
-- would have been macro-expanded).
-- Do not set the body, as it would trigger an assert during
-- macro-expansion (maybe this shouldn't be called for macro
-- expanded packages).
Callee_Bod := Get_Subprogram_Body_Or_Generic (Callee);
-- Check pure.
if Callee_Bod = Null_Iir then
-- No body yet for the subprogram called.
-- Nothing can be extracted from it, postpone the checks until
-- elaboration.
Res := Update_Pure_Missing;
else
-- Second loop: recurse if a state is not known.
if J = 1
and then
((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
and then Get_Purity_State (Callee) = Unknown)
or else Get_Wait_State (Callee) = Unknown
or else Get_All_Sensitized_State (Callee) = Unknown)
then
Res1 := Update_And_Check_Pure_Wait (Callee);
if Res1 = Update_Pure_Missing then
Res := Update_Pure_Missing;
end if;
end if;
-- Check purity only if the subprogram is not impure.
if Depth /= Iir_Depth_Impure then
Depth_Callee := Get_Impure_Depth (Callee_Bod);
-- Check purity depth.
if Depth_Callee < Subprg_Depth then
-- The call is an impure call because it calls an outer
-- subprogram (or an impure subprogram).
-- FIXME: check the compare.
Depth_Callee := Iir_Depth_Impure;
if Kind = K_Function then
-- FIXME: report call location
Error_Pure (Elaboration, Subprg_Bod, Callee, Null_Iir);
end if;
end if;
-- Update purity depth.
if Depth_Callee < Depth then
Depth := Depth_Callee;
if Kind = K_Procedure then
-- Update for recursivity.
Set_Impure_Depth (Subprg_Bod, Depth);
if Depth = Iir_Depth_Impure then
Set_Purity_State (Subprg, Impure);
end if;
end if;
end if;
end if;
end if;
-- Check wait.
if Has_Wait_Errors = False
and then Get_Wait_State (Callee) = True
then
if Kind = K_Procedure then
Set_Wait_State (Subprg, True);
else
Error_Wait (Subprg, Callee);
Has_Wait_Errors := True;
end if;
end if;
if Get_All_Sensitized_State (Callee) = Invalid_Signal then
case Kind is
when K_Function | K_Procedure =>
Set_All_Sensitized_State (Subprg, Invalid_Signal);
when K_Process =>
-- LRM08 11.3
--
-- It is an error if a process statement with the
-- reserved word ALL as its process sensitivity list
-- is the parent of a subprogram declared in a design
-- unit other than that containing the process statement
-- and the subprogram reads an explicitly declared
-- signal that is not a formal signal parameter or
-- member of a formal signal parameter of the
-- subprogram or of any of its parents. Similarly,
-- it is an error if such subprogram reads an implicit
-- signal whose explicit ancestor is not a formal signal
-- parameter or member of a formal parameter of
-- the subprogram or of any of its parents.
Report_Start_Group;
Error_Msg_Sem
(+Subprg, "all-sensitized %n can't call %n",
(+Subprg, +Callee));
Error_Msg_Sem
(+Subprg,
" (as this subprogram reads (indirectly) a signal)");
Report_End_Group;
end case;
end if;
-- Keep in list.
if Callee_Bod = Null_Iir
or else
(Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
and then Get_Purity_State (Callee) = Unknown
and then Depth /= Iir_Depth_Impure)
or else
(Get_Wait_State (Callee) = Unknown
and then (Kind /= K_Procedure
or else Get_Wait_State (Subprg) = Unknown))
or else
(Vhdl_Std >= Vhdl_08
and then
(Get_All_Sensitized_State (Callee) = Unknown
or else Get_All_Sensitized_State (Callee) = Read_Signal))
then
Append_Element (New_List, Callee);
end if;
Next (Callees_It);
end loop;
-- End of callee loop.
if Is_Empty (New_List) then
Destroy_Iir_List (Callees_List);
Callees_List := Null_Iir_List;
Destroy_Iir_List (New_List);
if Kind = K_Procedure then
if Get_Purity_State (Subprg) = Unknown then
Set_Purity_State (Subprg, Maybe_Impure);
end if;
if Get_Wait_State (Subprg) = Unknown then
Set_Wait_State (Subprg, False);
end if;
end if;
if Kind = K_Procedure or Kind = K_Function then
if Get_All_Sensitized_State (Subprg) = Unknown then
Set_All_Sensitized_State (Subprg, No_Signal);
end if;
end if;
Res := Update_Pure_Done;
exit;
else
Destroy_Iir_List (Callees_List);
Callees_List := New_List;
end if;
end loop;
Set_Callees_List (Callees_List_Holder, New_List);
return Res;
end Update_And_Check_Pure_Wait;
-- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or
-- process). Return False if the analysis is incomplete (and must
-- be deferred).
function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean
is
Res : Update_Pure_Status;
begin
Res := Update_And_Check_Pure_Wait (Subprg);
case Res is
when Update_Pure_Done =>
return True;
when Update_Pure_Missing =>
return False;
when Update_Pure_Unknown =>
-- The purity/wait is unknown, but all callee were walked.
-- This means there are recursive calls but without violations.
if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then
if Get_Purity_State (Subprg) = Unknown then
Set_Purity_State (Subprg, Maybe_Impure);
end if;
if Get_Wait_State (Subprg) = Unknown then
Set_Wait_State (Subprg, False);
end if;
end if;
if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then
if Get_All_Sensitized_State (Subprg) = Unknown then
Set_All_Sensitized_State (Subprg, No_Signal);
end if;
end if;
return True;
end case;
end Root_Update_And_Check_Pure_Wait;
procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit;
Emit_Warnings : Boolean)
is
List : Iir_List;
El : Iir;
It : List_Iterator;
Keep : Boolean;
New_List : Iir_List;
begin
List := Get_Analysis_Checks_List (Unit);
if List = Null_Iir_List then
-- Return now if there is nothing to check.
return;
end if;
New_List := Create_Iir_List;
It := List_Iterate (List);
while Is_Valid (It) loop
El := Get_Element (It);
Keep := False;
case Get_Kind (El) is
when Iir_Kind_Function_Declaration =>
-- FIXME: remove from list if fully tested ?
if not Root_Update_And_Check_Pure_Wait (El) then
Keep := True;
if Emit_Warnings then
declare
Bod : constant Iir := Get_Subprogram_Body (El);
Callees : constant Iir_List := Get_Callees_List (Bod);
pragma Assert (Callees /= Null_Iir_List);
Callee : constant Iir := Get_First_Element (Callees);
begin
Report_Start_Group;
Warning_Msg_Sem
(Warnid_Delayed_Checks, +El,
"can't assert that all calls in %n"
& " are pure or have not wait;"
& " will be checked at elaboration", +El);
-- FIXME: could improve this message by displaying
-- the chain of calls until the first subprograms in
-- unknown state.
Warning_Msg_Sem
(Warnid_Delayed_Checks, +Callee,
"(first such call is to %n)", +Callee);
Report_End_Group;
end;
end if;
end if;
when Iir_Kind_Sensitized_Process_Statement =>
if not Root_Update_And_Check_Pure_Wait (El) then
Keep := True;
if Emit_Warnings then
Warning_Msg_Sem
(Warnid_Delayed_Checks, +El,
"can't assert that %n has no wait; "
& "will be checked at elaboration", +El);
end if;
end if;
when others =>
Error_Kind ("sem_analysis_checks_list", El);
end case;
if Keep then
Append_Element (New_List, El);
end if;
Next (It);
end loop;
if Is_Empty (New_List) then
Destroy_Iir_List (New_List);
New_List := Null_Iir_List; -- OK, redundant but clearer.
end if;
Destroy_Iir_List (List);
Set_Analysis_Checks_List (Unit, New_List);
end Sem_Analysis_Checks_List;
-- Return true if package declaration DECL needs a body.
-- Ie, it contains subprogram specification or deferred constants.
function Package_Need_Body_P (Decl: Iir_Package_Declaration)
return Boolean
is
El: Iir;
Def : Iir;
begin
El := Get_Declaration_Chain (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
if not Is_Implicit_Subprogram (El) then
return True;
end if;
when Iir_Kind_Constant_Declaration =>
if Get_Default_Value (El) = Null_Iir then
return True;
end if;
when Iir_Kind_Variable_Declaration
| Iir_Kind_File_Declaration
| Iir_Kind_Signal_Declaration
| Iir_Kind_Object_Alias_Declaration
| Iir_Kind_Non_Object_Alias_Declaration
| Iir_Kind_Group_Template_Declaration
| Iir_Kind_Group_Declaration =>
null;
when Iir_Kind_Type_Declaration =>
Def := Get_Type_Definition (El);
if Def /= Null_Iir
and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration
then
return True;
end if;
when Iir_Kind_Anonymous_Type_Declaration
| Iir_Kind_Subtype_Declaration =>
null;
when Iir_Kind_Attribute_Declaration
| Iir_Kind_Attribute_Specification =>
null;
when Iir_Kind_Disconnection_Specification =>
null;
when Iir_Kind_Use_Clause =>
null;
when Iir_Kind_Component_Declaration =>
null;
when Iir_Kind_Protected_Type_Body =>
null;
when Iir_Kind_Package_Declaration =>
-- LRM08 4.8 Package bodies
-- A package body that is not a library unit shall appear
-- immediately within the same declarative region as the
-- corresponding package declaration and textually subsequent
-- to that package declaration.
if Get_Need_Body (El) then
return True;
end if;
when Iir_Kind_Package_Body =>
null;
when Iir_Kind_Package_Instantiation_Declaration =>
null;
when Iir_Kind_Nature_Declaration
| Iir_Kind_Subnature_Declaration =>
null;
when Iir_Kind_Terminal_Declaration =>
null;
when others =>
pragma Assert (Flags.Flag_Force_Analysis);
null;
end case;
El := Get_Chain (El);
end loop;
return False;
end Package_Need_Body_P;
-- Return true if package declaration DECL contains at least one package
-- instantiation that needs a body.
function Package_Need_Instance_Bodies_P (Decl: Iir_Package_Declaration)
return Boolean
is
El: Iir;
begin
El := Get_Declaration_Chain (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Package_Instantiation_Declaration =>
declare
Pkg : constant Iir := Get_Uninstantiated_Package_Decl (El);
begin
if not Is_Error (Pkg)
and then Get_Need_Body (Pkg)
then
return True;
end if;
end;
when others =>
null;
end case;
El := Get_Chain (El);
end loop;
return False;
end Package_Need_Instance_Bodies_P;
-- Return true if uninstantiated pckage DECL must be macro-expanded (at
-- least one interface type).
function Is_Package_Macro_Expanded
(Decl : Iir_Package_Declaration) return Boolean
is
Header : constant Iir := Get_Package_Header (Decl);
Inter : Iir;
begin
Inter := Get_Generic_Chain (Header);
while Is_Valid (Inter) loop
case Iir_Kinds_Interface_Declaration (Get_Kind (Inter)) is
when Iir_Kinds_Interface_Object_Declaration
| Iir_Kind_Interface_Terminal_Declaration =>
null;
when Iir_Kind_Interface_Type_Declaration =>
return True;
when Iir_Kind_Interface_Package_Declaration =>
declare
Pkg : constant Iir :=
Get_Uninstantiated_Package_Decl (Inter);
begin
-- Could be an error.
if Get_Kind (Pkg) = Iir_Kind_Package_Declaration
and then Get_Macro_Expanded_Flag (Pkg)
then
return True;
end if;
end;
when Iir_Kinds_Interface_Subprogram_Declaration =>
return True;
end case;
Inter := Get_Chain (Inter);
end loop;
return False;
end Is_Package_Macro_Expanded;
-- LRM 2.5 Package Declarations.
procedure Sem_Package_Declaration (Pkg : Iir_Package_Declaration)
is
Unit : constant Iir_Design_Unit := Get_Design_Unit (Pkg);
Header : constant Iir := Get_Package_Header (Pkg);
Implicit : Implicit_Signal_Declaration_Type;
begin
Sem_Scopes.Add_Name (Pkg);
Set_Visible_Flag (Pkg, True);
Xref_Decl (Pkg);
Set_Is_Within_Flag (Pkg, True);
-- Identify IEEE.Std_Logic_1164 for VHDL08.
if Get_Identifier (Pkg) = Std_Names.Name_Std_Logic_1164
and then (Get_Identifier (Get_Library (Get_Design_File (Unit)))
= Std_Names.Name_Ieee)
then
Vhdl.Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Pkg;
end if;
-- LRM93 10.1 Declarative Region
-- 4. A package declaration, together with the corresponding
-- body (if any).
Open_Declarative_Region;
Push_Signals_Declarative_Part (Implicit, Pkg);
if Header /= Null_Iir then
declare
Generic_Chain : constant Iir := Get_Generic_Chain (Header);
Generic_Map : constant Iir :=
Get_Generic_Map_Aspect_Chain (Header);
Assoc_El : Iir;
Inter_El : Iir;
Inter : Iir;
begin
Sem_Interface_Chain (Generic_Chain, Generic_Interface_List);
if Generic_Map /= Null_Iir then
-- Generic-mapped packages are not macro-expanded.
Set_Macro_Expanded_Flag (Pkg, False);
if Sem_Generic_Association_Chain (Header, Header) then
-- For generic-mapped packages, use the actual type for
-- interface type.
Assoc_El := Get_Generic_Map_Aspect_Chain (Header);
Inter_El := Generic_Chain;
while Is_Valid (Assoc_El) loop
if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_Type
then
Inter :=
Get_Association_Interface (Assoc_El, Inter_El);
Sem_Inst.Substitute_On_Chain
(Generic_Chain,
Get_Type (Inter),
Get_Type (Get_Named_Entity
(Get_Actual (Assoc_El))));
end if;
Next_Association_Interface (Assoc_El, Inter_El);
end loop;
end if;
else
-- Uninstantiated package. Maybe macro expanded.
Set_Macro_Expanded_Flag
(Pkg, Is_Package_Macro_Expanded (Pkg));
end if;
end;
else
-- Simple packages are never expanded.
Set_Macro_Expanded_Flag (Pkg, False);
end if;
Sem_Declaration_Chain (Pkg);
-- GHDL: subprogram bodies appear in package body.
Pop_Signals_Declarative_Part (Implicit);
Close_Declarative_Region;
Set_Is_Within_Flag (Pkg, False);
Set_Need_Body (Pkg, Package_Need_Body_P (Pkg));
if Vhdl_Std >= Vhdl_08 then
Set_Need_Instance_Bodies
(Pkg, Package_Need_Instance_Bodies_P (Pkg));
end if;
end Sem_Package_Declaration;
-- LRM 2.6 Package Bodies.
procedure Sem_Package_Body (Decl : Iir)
is
Package_Ident : constant Name_Id := Get_Identifier (Decl);
Package_Decl : Iir;
begin
-- First, find the package declaration.
if not Is_Nested_Package (Decl) then
declare
Design_Unit: Iir_Design_Unit;
begin
Design_Unit := Load_Primary_Unit
(Get_Library (Get_Design_File (Get_Current_Design_Unit)),
Package_Ident, Decl);
if Design_Unit = Null_Iir then
Error_Msg_Sem
(+Decl, "package %i was not analysed", +Package_Ident);
return;
end if;
Package_Decl := Get_Library_Unit (Design_Unit);
if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then
Error_Msg_Sem
(+Decl, "primary unit %i is not a package", +Package_Ident);
return;
end if;
-- LRM08 13.5 Order of analysis
-- In each case, the second unit depends on the first unit
Add_Dependence (Design_Unit);
Add_Name (Design_Unit);
-- Add the context clauses from the primary unit.
Add_Context_Clauses (Design_Unit);
end;
else
declare
Interp : Name_Interpretation_Type;
begin
Interp := Get_Interpretation (Get_Identifier (Decl));
if not Valid_Interpretation (Interp)
or else not Is_In_Current_Declarative_Region (Interp)
or else Is_Potentially_Visible (Interp)
then
Error_Msg_Sem
(+Decl, "no corresponding package declaration for %i",
+Package_Ident);
return;
end if;
Package_Decl := Get_Declaration (Interp);
if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then
Error_Msg_Sem
(+Decl, "declaration %i is not a package", +Package_Ident);
return;
end if;
end;
end if;
-- Emit a warning is a body is not necessary.
if not Get_Need_Body (Package_Decl) then
Warning_Msg_Sem (Warnid_Body, +Decl,
"%n does not require a body", +Package_Decl);
end if;
Set_Package (Decl, Package_Decl);
Xref_Body (Decl, Package_Decl);
Set_Package_Body (Package_Decl, Decl);
Set_Is_Within_Flag (Package_Decl, True);
-- LRM93 10.1 Declarative Region
-- 4. A package declaration, together with the corresponding
-- body (if any).
Open_Declarative_Region;
Sem_Scopes.Add_Package_Declarations (Package_Decl);
Sem_Declaration_Chain (Decl);
Check_Full_Declaration (Decl, Decl);
Check_Full_Declaration (Package_Decl, Decl);
Close_Declarative_Region;
Set_Is_Within_Flag (Package_Decl, False);
end Sem_Package_Body;
function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir
is
Name : Iir;
Pkg : Iir;
begin
Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl));
Set_Uninstantiated_Package_Name (Decl, Name);
Pkg := Get_Named_Entity (Name);
if Is_Error (Pkg) then
null;
elsif Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then
Error_Class_Match (Name, "package");
Pkg := Create_Error (Pkg);
elsif not Is_Uninstantiated_Package (Pkg) then
Error_Msg_Sem (+Name, "%n is not an uninstantiated package", +Pkg);
Pkg := Create_Error (Pkg);
end if;
Set_Uninstantiated_Package_Decl (Decl, Pkg);
return Pkg;
end Sem_Uninstantiated_Package_Name;
-- LRM08 4.9 Package Instantiation Declaration
procedure Sem_Package_Instantiation_Declaration (Decl : Iir)
is
Hdr : Iir;
Pkg : Iir;
Bod : Iir_Design_Unit;
begin
Sem_Scopes.Add_Name (Decl);
Set_Visible_Flag (Decl, True);
Xref_Decl (Decl);
-- LRM08 4.9
-- The uninstantiated package name shall denote an uninstantiated
-- package declared in a package declaration.
Pkg := Sem_Uninstantiated_Package_Name (Decl);
if Pkg = Null_Iir or Is_Error (Pkg) then
-- What could be done ?
return;
end if;
-- LRM08 4.9
-- The generic map aspect, if present, optionally associates a single
-- actual with each formal generic (or member thereof) in the
-- corresponding package declaration. Each formal generic (or member
-- thereof) shall be associated at most once.
-- GHDL: the generics are first instantiated (ie copied) and then
-- the actuals are associated with the instantiated formal.
-- FIXME: do it in Instantiate_Package_Declaration ?
Hdr := Get_Package_Header (Pkg);
if not Sem_Generic_Association_Chain (Hdr, Decl) then
-- FIXME: stop analysis here ?
return;
end if;
-- FIXME: unless the parent is a package declaration library unit, the
-- design unit depends on the body.
if Get_Need_Body (Pkg) and then not Is_Nested_Package (Pkg) then
Bod := Get_Package_Body (Pkg);
if Is_Null (Bod) then
Bod := Load_Secondary_Unit
(Get_Design_Unit (Pkg), Null_Identifier, Decl);
else
Bod := Get_Design_Unit (Bod);
end if;
if Is_Null (Bod) then
Error_Msg_Sem (+Decl, "cannot find package body of %n", +Pkg);
else
Add_Dependence (Bod);
end if;
end if;
-- Instantiate the declaration after analyse of the body. So that
-- the use_flag on the declaration can be propagated to the instance.
Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg);
end Sem_Package_Instantiation_Declaration;
-- LRM 10.4 Use Clauses.
procedure Sem_Use_Clause_Name (Clause : Iir)
is
Name: Iir;
Prefix: Iir;
Name_Prefix : Iir;
begin
-- LRM93 10.4
-- A use clause achieves direct visibility of declarations that are
-- visible by selection.
-- Each selected name is a use clause identifies one or more
-- declarations that will potentialy become directly visible.
Name := Get_Selected_Name (Clause);
if Name = Null_Iir then
pragma Assert (Flags.Flag_Force_Analysis);
return;
end if;
case Get_Kind (Name) is
when Iir_Kind_Selected_By_All_Name
| Iir_Kind_Selected_Name =>
Name_Prefix := Get_Prefix (Name);
when others =>
Error_Msg_Sem (+Name, "use clause allows only selected name");
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end case;
case Get_Kind (Name_Prefix) is
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
null;
when others =>
Error_Msg_Sem
(+Name_Prefix,
"use clause prefix must be a name or a selected name");
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end case;
Name_Prefix := Sem_Denoting_Name (Name_Prefix);
Set_Prefix (Name, Name_Prefix);
Prefix := Get_Named_Entity (Name_Prefix);
if Is_Error (Prefix) then
Set_Selected_Name (Clause, Create_Error_Name (Name));
return;
end if;
-- LRM 10.4 Use Clauses
--
-- If the suffix of the selected name is [...], then the
-- selected name identifies only the declaration(s) of that
-- [...] contained within the package or library denoted by
-- the prefix of the selected name.
--
-- If the suffix is the reserved word ALL, then the selected name
-- identifies all declarations that are contained within the package
-- or library denoted by the prefix of the selected name.
--
-- GHDL: therefore, the suffix must be either a package or a library.
case Get_Kind (Prefix) is
when Iir_Kind_Library_Declaration =>
null;
when Iir_Kind_Package_Instantiation_Declaration
| Iir_Kind_Interface_Package_Declaration =>
null;
when Iir_Kind_Package_Declaration =>
-- LRM08 12.4 Use clauses
-- It is an error if the prefix of a selected name in a use
-- clause denotes an uninstantiated package.
if Is_Uninstantiated_Package (Prefix) then
Error_Msg_Sem
(+Name_Prefix,
"use of uninstantiated package is not allowed");
Set_Prefix (Name, Create_Error_Name (Name_Prefix));
return;
end if;
when others =>
Error_Msg_Sem
(+Name, "prefix must designate a package or a library");
Set_Prefix (Name, Create_Error_Name (Name_Prefix));
return;
end case;
case Get_Kind (Name) is
when Iir_Kind_Selected_Name =>
Sem_Name (Name, True);
case Get_Kind (Get_Named_Entity (Name)) is
when Iir_Kind_Error =>
-- Continue in case of error.
null;
when Iir_Kind_Overload_List =>
-- Analyze is correct as is.
null;
when others =>
Name := Finish_Sem_Name (Name);
Set_Selected_Name (Clause, Name);
end case;
when Iir_Kind_Selected_By_All_Name =>
null;
when others =>
raise Internal_Error;
end case;
end Sem_Use_Clause_Name;
-- LRM 10.4 Use Clauses.
procedure Sem_Use_Clause (Clauses: Iir_Use_Clause)
is
Clause : Iir_Use_Clause;
begin
Clause := Clauses;
loop
Sem_Use_Clause_Name (Clause);
Clause := Get_Use_Clause_Chain (Clause);
exit when Clause = Null_Iir;
end loop;
-- LRM 10.4
-- For each use clause, there is a certain region of text called the
-- scope of the use clause. This region starts immediatly after the
-- use clause.
Sem_Scopes.Add_Use_Clause (Clauses);
end Sem_Use_Clause;
-- LRM 11.2 Design Libraries.
procedure Sem_Library_Clause (Decl: Iir_Library_Clause)
is
Ident : Name_Id;
Lib: Iir;
begin
-- GHDL: 'redeclaration' is handled in sem_scopes.
Ident := Get_Identifier (Decl);
Lib := Libraries.Get_Library (Ident, Get_Location (Decl));
if Lib = Null_Iir then
Error_Msg_Sem (+Decl, "no resource library %i", +Ident);
else
Set_Library_Declaration (Decl, Lib);
Sem_Scopes.Add_Name (Lib, Ident, False);
Set_Visible_Flag (Lib, True);
-- Override the location of the library. Even if the library is
-- not really declared by the library clause (it is almost pre-
-- declared), it improves error messages.
-- Note: library clauses of dependences will overwrite the location,
-- defeating the purpose of it.
Location_Copy (Lib, Decl);
Xref_Ref (Decl, Lib);
end if;
end Sem_Library_Clause;
-- LRM08 13.4 Context clauses.
procedure Sem_One_Context_Reference (Ref : Iir)
is
Name : Iir;
Ent : Iir;
begin
Name := Get_Selected_Name (Ref);
if Get_Kind (Name) /= Iir_Kind_Selected_Name then
Error_Msg_Sem
(+Name, "context reference only allows selected names");
return;
end if;
Name := Sem_Denoting_Name (Name);
Set_Selected_Name (Ref, Name);
Ent := Get_Named_Entity (Name);
if Is_Error (Ent) then
return;
end if;
-- LRM08 13.4 Context clauses
-- It is an error if a selected name in a context reference does not
-- denote a context declaration.
if Get_Kind (Ent) /= Iir_Kind_Context_Declaration then
Error_Msg_Sem (+Name, "name must denote a context declaration");
Set_Named_Entity (Name, Null_Iir);
return;
end if;
end Sem_One_Context_Reference;
-- LRM08 13.4 Context clauses.
procedure Sem_Context_Reference (Ctxt : Iir)
is
Ref : Iir;
begin
Ref := Ctxt;
loop
Sem_One_Context_Reference (Ref);
Ref := Get_Context_Reference_Chain (Ref);
exit when Ref = Null_Iir;
end loop;
-- FIXME: must be done clause after clause ?
Add_Context_Reference (Ctxt);
end Sem_Context_Reference;
-- LRM 11.3 Context Clauses.
procedure Sem_Context_Clauses (Unit: Iir)
is
El: Iir;
begin
El := Get_Context_Items (Unit);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Use_Clause =>
Sem_Use_Clause (El);
when Iir_Kind_Library_Clause =>
Sem_Library_Clause (El);
when Iir_Kind_Context_Reference =>
Sem_Context_Reference (El);
when others =>
Error_Kind ("sem_context_clauses", El);
end case;
El := Get_Chain (El);
end loop;
end Sem_Context_Clauses;
-- LRM08 13.3 Context declarations
procedure Sem_Context_Declaration (Decl: Iir)
is
-- Return TRUE iff the first prefix of NAME denotes library WORK.
function Has_Work_Library_Prefix (Name : Iir) return Boolean
is
Prefix : Iir;
begin
Prefix := Name;
while Get_Kind (Prefix) = Iir_Kind_Selected_Name
or else Get_Kind (Prefix) = Iir_Kind_Selected_By_All_Name
loop
Prefix := Get_Prefix (Prefix);
end loop;
return Get_Kind (Prefix) = Iir_Kind_Simple_Name
and then Get_Identifier (Prefix) = Std_Names.Name_Work
and then (Get_Kind (Get_Named_Entity (Prefix))
= Iir_Kind_Library_Declaration);
end Has_Work_Library_Prefix;
procedure Error_Work_Prefix (Loc : Iir) is
begin
Error_Msg_Sem
(+Loc, "'work' not allowed as prefix in context declaration");
end Error_Work_Prefix;
El : Iir;
El1 : Iir;
begin
Sem_Scopes.Add_Name (Decl);
Xref_Decl (Decl);
Sem_Context_Clauses (Decl);
El := Get_Context_Items (Decl);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Library_Clause =>
-- LRM08 13.3 Context declarations
-- It is an error if a library clause in a context declaration
-- defines the library logical name WORK, [...]
if Get_Identifier (El) = Std_Names.Name_Work then
Error_Msg_Sem
(+El, "'library work' not allowed in context declaration");
end if;
when Iir_Kind_Use_Clause =>
-- LRM08 13.3 Context declarations
-- [...] or if a selected name in a use clause [or a context
-- reference] in a context declaration has the library logic
-- name WORK as a prefix.
El1 := El;
while El1 /= Null_Iir loop
if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then
Error_Work_Prefix (El1);
exit;
end if;
El1 := Get_Use_Clause_Chain (El1);
end loop;
when Iir_Kind_Context_Reference =>
-- LRM08 13.3 Context declarations
-- [...] or if a selected name in [a use clause or] a context
-- reference in a context declaration has the library logic
-- name WORK as a prefix.
El1 := El;
while El1 /= Null_Iir loop
if Has_Work_Library_Prefix (Get_Selected_Name (El1)) then
Error_Work_Prefix (El1);
exit;
end if;
El1 := Get_Context_Reference_Chain (El1);
end loop;
when others =>
raise Internal_Error;
end case;
El := Get_Chain (El);
end loop;
-- GHDL: forbid self-reference by making declaration visible at the end.
-- This violates LRM08 12.3 Visibility: A declaration is visible only
-- within a certain part of its scope; ...
Set_Visible_Flag (Decl, True);
end Sem_Context_Declaration;
-- Access to the current design unit. This is set, saved, restored, cleared
-- by the procedure semantic.
Current_Design_Unit: Iir_Design_Unit := Null_Iir;
function Get_Current_Design_Unit return Iir_Design_Unit is
begin
return Current_Design_Unit;
end Get_Current_Design_Unit;
-- LRM 11.1 Design units.
procedure Semantic (Design_Unit : Iir_Design_Unit)
is
Library_Unit : constant Iir := Get_Library_Unit (Design_Unit);
Library : constant Iir := Get_Library (Get_Design_File (Design_Unit));
Prev_Unit : Iir;
Old_Design_Unit : Iir_Design_Unit;
Implicit : Implicit_Signal_Declaration_Type;
begin
-- Sanity check: can analyze either previously analyzed unit or just
-- parsed unit.
case Get_Date (Design_Unit) is
when Date_Parsed =>
Set_Date (Design_Unit, Date_Analyzing);
when Date_Valid =>
null;
when Date_Obsolete =>
-- This happens only when design files are added into the library
-- and keeping obsolete units (eg: to pretty print a file).
Set_Date (Design_Unit, Date_Analyzing);
when others =>
raise Internal_Error;
end case;
-- If there is already a unit with the same name, mark it as being
-- replaced.
if Library_Unit /= Null_Iir then
if Get_Kind (Library_Unit) in Iir_Kinds_Primary_Unit then
Prev_Unit := Libraries.Find_Primary_Unit
(Library, Get_Identifier (Library_Unit));
if Is_Valid (Prev_Unit) and then Prev_Unit /= Design_Unit then
Set_Date (Prev_Unit, Date_Replacing);
end if;
end if;
end if;
-- Save and set current_design_unit.
Old_Design_Unit := Current_Design_Unit;
Current_Design_Unit := Design_Unit;
Push_Signals_Declarative_Part (Implicit, Null_Iir);
-- Have a clean and empty state for scopes.
Push_Interpretations;
-- LRM02 10.1 Declarative Region.
-- In addition to the above declarative region, there is a root
-- declarative region, not associated with a portion of the text of the
-- description, but encompassing any given primary unit. At the
-- beginning of the analysis of a given primary unit, there are no
-- declarations whose scopes (see 10.2) are within the root declarative
-- region. Moreover, the root declarative region associated with any
-- given secondary unit is the root declarative region of the
-- corresponding primary unit.
-- GHDL: for any revision of VHDL, a root declarative region is created,
-- due to reasons given by LCS 3 (VHDL Issue # 1028).
Open_Declarative_Region;
-- LRM 11.2
-- Every design unit is assumed to contain the following implicit
-- context items as part of its context clause:
-- library STD, WORK; use STD.STANDARD.all;
Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False);
Sem_Scopes.Add_Name (Library, Std_Names.Name_Work, False);
Sem_Scopes.Use_All_Names (Standard_Package);
-- Use pre-defined locations for STD and WORK library (as they may
-- be later overriden).
Set_Location (Libraries.Std_Library, Libraries.Library_Location);
Set_Location (Library, Libraries.Library_Location);
if Get_Dependence_List (Design_Unit) = Null_Iir_List then
Set_Dependence_List (Design_Unit, Create_Iir_List);
end if;
Add_Dependence (Std_Standard_Unit);
-- Analyze context clauses.
Sem_Context_Clauses (Design_Unit);
-- Analyze the library unit.
if Library_Unit /= Null_Iir then
-- Can be null_iir in case of parse error.
case Iir_Kinds_Library_Unit (Get_Kind (Library_Unit)) is
when Iir_Kind_Entity_Declaration =>
Sem_Entity_Declaration (Library_Unit);
when Iir_Kind_Architecture_Body =>
Sem_Architecture_Body (Library_Unit);
when Iir_Kind_Package_Declaration =>
Sem_Package_Declaration (Library_Unit);
when Iir_Kind_Package_Body =>
Sem_Package_Body (Library_Unit);
when Iir_Kind_Configuration_Declaration =>
Sem_Configuration_Declaration (Library_Unit);
when Iir_Kind_Package_Instantiation_Declaration =>
Sem_Package_Instantiation_Declaration (Library_Unit);
when Iir_Kind_Context_Declaration =>
Sem_Context_Declaration (Library_Unit);
when Iir_Kinds_Verification_Unit =>
Sem_Psl.Sem_Psl_Verification_Unit (Library_Unit);
when Iir_Kind_Foreign_Module =>
raise Internal_Error;
end case;
end if;
Close_Declarative_Region;
Pop_Interpretations;
if Get_Date (Design_Unit) = Date_Analyzing then
Set_Date (Design_Unit, Date_Analyzed);
end if;
if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then
Sem_Analysis_Checks_List (Design_Unit, False);
end if;
-- Restore current_design_unit.
Current_Design_Unit := Old_Design_Unit;
Pop_Signals_Declarative_Part (Implicit);
end Semantic;
end Vhdl.Sem;
|