aboutsummaryrefslogtreecommitdiff
path: root/gcc/tree-data-ref.c
blob: 26387f86b873cdd687aaa447e79a362c4d6e2412 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
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
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
/* Data references and dependences detectors.
   Copyright (C) 2003-2017 Free Software Foundation, Inc.
   Contributed by Sebastian Pop <pop@cri.ensmp.fr>

This file is part of GCC.

GCC 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 3, or (at your option) any later
version.

GCC 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 GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

/* This pass walks a given loop structure searching for array
   references.  The information about the array accesses is recorded
   in DATA_REFERENCE structures.

   The basic test for determining the dependences is:
   given two access functions chrec1 and chrec2 to a same array, and
   x and y two vectors from the iteration domain, the same element of
   the array is accessed twice at iterations x and y if and only if:
   |             chrec1 (x) == chrec2 (y).

   The goals of this analysis are:

   - to determine the independence: the relation between two
     independent accesses is qualified with the chrec_known (this
     information allows a loop parallelization),

   - when two data references access the same data, to qualify the
     dependence relation with classic dependence representations:

       - distance vectors
       - direction vectors
       - loop carried level dependence
       - polyhedron dependence
     or with the chains of recurrences based representation,

   - to define a knowledge base for storing the data dependence
     information,

   - to define an interface to access this data.


   Definitions:

   - subscript: given two array accesses a subscript is the tuple
   composed of the access functions for a given dimension.  Example:
   Given A[f1][f2][f3] and B[g1][g2][g3], there are three subscripts:
   (f1, g1), (f2, g2), (f3, g3).

   - Diophantine equation: an equation whose coefficients and
   solutions are integer constants, for example the equation
   |   3*x + 2*y = 1
   has an integer solution x = 1 and y = -1.

   References:

   - "Advanced Compilation for High Performance Computing" by Randy
   Allen and Ken Kennedy.
   http://citeseer.ist.psu.edu/goff91practical.html

   - "Loop Transformations for Restructuring Compilers - The Foundations"
   by Utpal Banerjee.


*/

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "backend.h"
#include "rtl.h"
#include "tree.h"
#include "gimple.h"
#include "gimple-pretty-print.h"
#include "alias.h"
#include "fold-const.h"
#include "expr.h"
#include "gimple-iterator.h"
#include "tree-ssa-loop-niter.h"
#include "tree-ssa-loop.h"
#include "tree-ssa.h"
#include "cfgloop.h"
#include "tree-data-ref.h"
#include "tree-scalar-evolution.h"
#include "dumpfile.h"
#include "tree-affine.h"
#include "params.h"
#include "builtins.h"

static struct datadep_stats
{
  int num_dependence_tests;
  int num_dependence_dependent;
  int num_dependence_independent;
  int num_dependence_undetermined;

  int num_subscript_tests;
  int num_subscript_undetermined;
  int num_same_subscript_function;

  int num_ziv;
  int num_ziv_independent;
  int num_ziv_dependent;
  int num_ziv_unimplemented;

  int num_siv;
  int num_siv_independent;
  int num_siv_dependent;
  int num_siv_unimplemented;

  int num_miv;
  int num_miv_independent;
  int num_miv_dependent;
  int num_miv_unimplemented;
} dependence_stats;

static bool subscript_dependence_tester_1 (struct data_dependence_relation *,
					   unsigned int, unsigned int,
					   struct loop *);
/* Returns true iff A divides B.  */

static inline bool
tree_fold_divides_p (const_tree a, const_tree b)
{
  gcc_assert (TREE_CODE (a) == INTEGER_CST);
  gcc_assert (TREE_CODE (b) == INTEGER_CST);
  return integer_zerop (int_const_binop (TRUNC_MOD_EXPR, b, a));
}

/* Returns true iff A divides B.  */

static inline bool
int_divides_p (int a, int b)
{
  return ((b % a) == 0);
}

/* Return true if reference REF contains a union access.  */

static bool
ref_contains_union_access_p (tree ref)
{
  while (handled_component_p (ref))
    {
      ref = TREE_OPERAND (ref, 0);
      if (TREE_CODE (TREE_TYPE (ref)) == UNION_TYPE
	  || TREE_CODE (TREE_TYPE (ref)) == QUAL_UNION_TYPE)
	return true;
    }
  return false;
}



/* Dump into FILE all the data references from DATAREFS.  */

static void
dump_data_references (FILE *file, vec<data_reference_p> datarefs)
{
  unsigned int i;
  struct data_reference *dr;

  FOR_EACH_VEC_ELT (datarefs, i, dr)
    dump_data_reference (file, dr);
}

/* Unified dump into FILE all the data references from DATAREFS.  */

DEBUG_FUNCTION void
debug (vec<data_reference_p> &ref)
{
  dump_data_references (stderr, ref);
}

DEBUG_FUNCTION void
debug (vec<data_reference_p> *ptr)
{
  if (ptr)
    debug (*ptr);
  else
    fprintf (stderr, "<nil>\n");
}


/* Dump into STDERR all the data references from DATAREFS.  */

DEBUG_FUNCTION void
debug_data_references (vec<data_reference_p> datarefs)
{
  dump_data_references (stderr, datarefs);
}

/* Print to STDERR the data_reference DR.  */

DEBUG_FUNCTION void
debug_data_reference (struct data_reference *dr)
{
  dump_data_reference (stderr, dr);
}

/* Dump function for a DATA_REFERENCE structure.  */

void
dump_data_reference (FILE *outf,
		     struct data_reference *dr)
{
  unsigned int i;

  fprintf (outf, "#(Data Ref: \n");
  fprintf (outf, "#  bb: %d \n", gimple_bb (DR_STMT (dr))->index);
  fprintf (outf, "#  stmt: ");
  print_gimple_stmt (outf, DR_STMT (dr), 0);
  fprintf (outf, "#  ref: ");
  print_generic_stmt (outf, DR_REF (dr));
  fprintf (outf, "#  base_object: ");
  print_generic_stmt (outf, DR_BASE_OBJECT (dr));

  for (i = 0; i < DR_NUM_DIMENSIONS (dr); i++)
    {
      fprintf (outf, "#  Access function %d: ", i);
      print_generic_stmt (outf, DR_ACCESS_FN (dr, i));
    }
  fprintf (outf, "#)\n");
}

/* Unified dump function for a DATA_REFERENCE structure.  */

DEBUG_FUNCTION void
debug (data_reference &ref)
{
  dump_data_reference (stderr, &ref);
}

DEBUG_FUNCTION void
debug (data_reference *ptr)
{
  if (ptr)
    debug (*ptr);
  else
    fprintf (stderr, "<nil>\n");
}


/* Dumps the affine function described by FN to the file OUTF.  */

DEBUG_FUNCTION void
dump_affine_function (FILE *outf, affine_fn fn)
{
  unsigned i;
  tree coef;

  print_generic_expr (outf, fn[0], TDF_SLIM);
  for (i = 1; fn.iterate (i, &coef); i++)
    {
      fprintf (outf, " + ");
      print_generic_expr (outf, coef, TDF_SLIM);
      fprintf (outf, " * x_%u", i);
    }
}

/* Dumps the conflict function CF to the file OUTF.  */

DEBUG_FUNCTION void
dump_conflict_function (FILE *outf, conflict_function *cf)
{
  unsigned i;

  if (cf->n == NO_DEPENDENCE)
    fprintf (outf, "no dependence");
  else if (cf->n == NOT_KNOWN)
    fprintf (outf, "not known");
  else
    {
      for (i = 0; i < cf->n; i++)
	{
	  if (i != 0)
	    fprintf (outf, " ");
	  fprintf (outf, "[");
	  dump_affine_function (outf, cf->fns[i]);
	  fprintf (outf, "]");
	}
    }
}

/* Dump function for a SUBSCRIPT structure.  */

DEBUG_FUNCTION void
dump_subscript (FILE *outf, struct subscript *subscript)
{
  conflict_function *cf = SUB_CONFLICTS_IN_A (subscript);

  fprintf (outf, "\n (subscript \n");
  fprintf (outf, "  iterations_that_access_an_element_twice_in_A: ");
  dump_conflict_function (outf, cf);
  if (CF_NONTRIVIAL_P (cf))
    {
      tree last_iteration = SUB_LAST_CONFLICT (subscript);
      fprintf (outf, "\n  last_conflict: ");
      print_generic_expr (outf, last_iteration);
    }

  cf = SUB_CONFLICTS_IN_B (subscript);
  fprintf (outf, "\n  iterations_that_access_an_element_twice_in_B: ");
  dump_conflict_function (outf, cf);
  if (CF_NONTRIVIAL_P (cf))
    {
      tree last_iteration = SUB_LAST_CONFLICT (subscript);
      fprintf (outf, "\n  last_conflict: ");
      print_generic_expr (outf, last_iteration);
    }

  fprintf (outf, "\n  (Subscript distance: ");
  print_generic_expr (outf, SUB_DISTANCE (subscript));
  fprintf (outf, " ))\n");
}

/* Print the classic direction vector DIRV to OUTF.  */

DEBUG_FUNCTION void
print_direction_vector (FILE *outf,
			lambda_vector dirv,
			int length)
{
  int eq;

  for (eq = 0; eq < length; eq++)
    {
      enum data_dependence_direction dir = ((enum data_dependence_direction)
					    dirv[eq]);

      switch (dir)
	{
	case dir_positive:
	  fprintf (outf, "    +");
	  break;
	case dir_negative:
	  fprintf (outf, "    -");
	  break;
	case dir_equal:
	  fprintf (outf, "    =");
	  break;
	case dir_positive_or_equal:
	  fprintf (outf, "   +=");
	  break;
	case dir_positive_or_negative:
	  fprintf (outf, "   +-");
	  break;
	case dir_negative_or_equal:
	  fprintf (outf, "   -=");
	  break;
	case dir_star:
	  fprintf (outf, "    *");
	  break;
	default:
	  fprintf (outf, "indep");
	  break;
	}
    }
  fprintf (outf, "\n");
}

/* Print a vector of direction vectors.  */

DEBUG_FUNCTION void
print_dir_vectors (FILE *outf, vec<lambda_vector> dir_vects,
		   int length)
{
  unsigned j;
  lambda_vector v;

  FOR_EACH_VEC_ELT (dir_vects, j, v)
    print_direction_vector (outf, v, length);
}

/* Print out a vector VEC of length N to OUTFILE.  */

DEBUG_FUNCTION void
print_lambda_vector (FILE * outfile, lambda_vector vector, int n)
{
  int i;

  for (i = 0; i < n; i++)
    fprintf (outfile, "%3d ", vector[i]);
  fprintf (outfile, "\n");
}

/* Print a vector of distance vectors.  */

DEBUG_FUNCTION void
print_dist_vectors (FILE *outf, vec<lambda_vector> dist_vects,
		    int length)
{
  unsigned j;
  lambda_vector v;

  FOR_EACH_VEC_ELT (dist_vects, j, v)
    print_lambda_vector (outf, v, length);
}

/* Dump function for a DATA_DEPENDENCE_RELATION structure.  */

DEBUG_FUNCTION void
dump_data_dependence_relation (FILE *outf,
			       struct data_dependence_relation *ddr)
{
  struct data_reference *dra, *drb;

  fprintf (outf, "(Data Dep: \n");

  if (!ddr || DDR_ARE_DEPENDENT (ddr) == chrec_dont_know)
    {
      if (ddr)
	{
	  dra = DDR_A (ddr);
	  drb = DDR_B (ddr);
	  if (dra)
	    dump_data_reference (outf, dra);
	  else
	    fprintf (outf, "    (nil)\n");
	  if (drb)
	    dump_data_reference (outf, drb);
	  else
	    fprintf (outf, "    (nil)\n");
	}
      fprintf (outf, "    (don't know)\n)\n");
      return;
    }

  dra = DDR_A (ddr);
  drb = DDR_B (ddr);
  dump_data_reference (outf, dra);
  dump_data_reference (outf, drb);

  if (DDR_ARE_DEPENDENT (ddr) == chrec_known)
    fprintf (outf, "    (no dependence)\n");

  else if (DDR_ARE_DEPENDENT (ddr) == NULL_TREE)
    {
      unsigned int i;
      struct loop *loopi;

      subscript *sub;
      FOR_EACH_VEC_ELT (DDR_SUBSCRIPTS (ddr), i, sub)
	{
	  fprintf (outf, "  access_fn_A: ");
	  print_generic_stmt (outf, SUB_ACCESS_FN (sub, 0));
	  fprintf (outf, "  access_fn_B: ");
	  print_generic_stmt (outf, SUB_ACCESS_FN (sub, 1));
	  dump_subscript (outf, sub);
	}

      fprintf (outf, "  inner loop index: %d\n", DDR_INNER_LOOP (ddr));
      fprintf (outf, "  loop nest: (");
      FOR_EACH_VEC_ELT (DDR_LOOP_NEST (ddr), i, loopi)
	fprintf (outf, "%d ", loopi->num);
      fprintf (outf, ")\n");

      for (i = 0; i < DDR_NUM_DIST_VECTS (ddr); i++)
	{
	  fprintf (outf, "  distance_vector: ");
	  print_lambda_vector (outf, DDR_DIST_VECT (ddr, i),
			       DDR_NB_LOOPS (ddr));
	}

      for (i = 0; i < DDR_NUM_DIR_VECTS (ddr); i++)
	{
	  fprintf (outf, "  direction_vector: ");
	  print_direction_vector (outf, DDR_DIR_VECT (ddr, i),
				  DDR_NB_LOOPS (ddr));
	}
    }

  fprintf (outf, ")\n");
}

/* Debug version.  */

DEBUG_FUNCTION void
debug_data_dependence_relation (struct data_dependence_relation *ddr)
{
  dump_data_dependence_relation (stderr, ddr);
}

/* Dump into FILE all the dependence relations from DDRS.  */

DEBUG_FUNCTION void
dump_data_dependence_relations (FILE *file,
				vec<ddr_p> ddrs)
{
  unsigned int i;
  struct data_dependence_relation *ddr;

  FOR_EACH_VEC_ELT (ddrs, i, ddr)
    dump_data_dependence_relation (file, ddr);
}

DEBUG_FUNCTION void
debug (vec<ddr_p> &ref)
{
  dump_data_dependence_relations (stderr, ref);
}

DEBUG_FUNCTION void
debug (vec<ddr_p> *ptr)
{
  if (ptr)
    debug (*ptr);
  else
    fprintf (stderr, "<nil>\n");
}


/* Dump to STDERR all the dependence relations from DDRS.  */

DEBUG_FUNCTION void
debug_data_dependence_relations (vec<ddr_p> ddrs)
{
  dump_data_dependence_relations (stderr, ddrs);
}

/* Dumps the distance and direction vectors in FILE.  DDRS contains
   the dependence relations, and VECT_SIZE is the size of the
   dependence vectors, or in other words the number of loops in the
   considered nest.  */

DEBUG_FUNCTION void
dump_dist_dir_vectors (FILE *file, vec<ddr_p> ddrs)
{
  unsigned int i, j;
  struct data_dependence_relation *ddr;
  lambda_vector v;

  FOR_EACH_VEC_ELT (ddrs, i, ddr)
    if (DDR_ARE_DEPENDENT (ddr) == NULL_TREE && DDR_AFFINE_P (ddr))
      {
	FOR_EACH_VEC_ELT (DDR_DIST_VECTS (ddr), j, v)
	  {
	    fprintf (file, "DISTANCE_V (");
	    print_lambda_vector (file, v, DDR_NB_LOOPS (ddr));
	    fprintf (file, ")\n");
	  }

	FOR_EACH_VEC_ELT (DDR_DIR_VECTS (ddr), j, v)
	  {
	    fprintf (file, "DIRECTION_V (");
	    print_direction_vector (file, v, DDR_NB_LOOPS (ddr));
	    fprintf (file, ")\n");
	  }
      }

  fprintf (file, "\n\n");
}

/* Dumps the data dependence relations DDRS in FILE.  */

DEBUG_FUNCTION void
dump_ddrs (FILE *file, vec<ddr_p> ddrs)
{
  unsigned int i;
  struct data_dependence_relation *ddr;

  FOR_EACH_VEC_ELT (ddrs, i, ddr)
    dump_data_dependence_relation (file, ddr);

  fprintf (file, "\n\n");
}

DEBUG_FUNCTION void
debug_ddrs (vec<ddr_p> ddrs)
{
  dump_ddrs (stderr, ddrs);
}

/* Helper function for split_constant_offset.  Expresses OP0 CODE OP1
   (the type of the result is TYPE) as VAR + OFF, where OFF is a nonzero
   constant of type ssizetype, and returns true.  If we cannot do this
   with OFF nonzero, OFF and VAR are set to NULL_TREE instead and false
   is returned.  */

static bool
split_constant_offset_1 (tree type, tree op0, enum tree_code code, tree op1,
			 tree *var, tree *off)
{
  tree var0, var1;
  tree off0, off1;
  enum tree_code ocode = code;

  *var = NULL_TREE;
  *off = NULL_TREE;

  switch (code)
    {
    case INTEGER_CST:
      *var = build_int_cst (type, 0);
      *off = fold_convert (ssizetype, op0);
      return true;

    case POINTER_PLUS_EXPR:
      ocode = PLUS_EXPR;
      /* FALLTHROUGH */
    case PLUS_EXPR:
    case MINUS_EXPR:
      split_constant_offset (op0, &var0, &off0);
      split_constant_offset (op1, &var1, &off1);
      *var = fold_build2 (code, type, var0, var1);
      *off = size_binop (ocode, off0, off1);
      return true;

    case MULT_EXPR:
      if (TREE_CODE (op1) != INTEGER_CST)
	return false;

      split_constant_offset (op0, &var0, &off0);
      *var = fold_build2 (MULT_EXPR, type, var0, op1);
      *off = size_binop (MULT_EXPR, off0, fold_convert (ssizetype, op1));
      return true;

    case ADDR_EXPR:
      {
	tree base, poffset;
	HOST_WIDE_INT pbitsize, pbitpos;
	machine_mode pmode;
	int punsignedp, preversep, pvolatilep;

	op0 = TREE_OPERAND (op0, 0);
	base
	  = get_inner_reference (op0, &pbitsize, &pbitpos, &poffset, &pmode,
				 &punsignedp, &preversep, &pvolatilep);

	if (pbitpos % BITS_PER_UNIT != 0)
	  return false;
	base = build_fold_addr_expr (base);
	off0 = ssize_int (pbitpos / BITS_PER_UNIT);

	if (poffset)
	  {
	    split_constant_offset (poffset, &poffset, &off1);
	    off0 = size_binop (PLUS_EXPR, off0, off1);
	    if (POINTER_TYPE_P (TREE_TYPE (base)))
	      base = fold_build_pointer_plus (base, poffset);
	    else
	      base = fold_build2 (PLUS_EXPR, TREE_TYPE (base), base,
				  fold_convert (TREE_TYPE (base), poffset));
	  }

	var0 = fold_convert (type, base);

	/* If variable length types are involved, punt, otherwise casts
	   might be converted into ARRAY_REFs in gimplify_conversion.
	   To compute that ARRAY_REF's element size TYPE_SIZE_UNIT, which
	   possibly no longer appears in current GIMPLE, might resurface.
	   This perhaps could run
	   if (CONVERT_EXPR_P (var0))
	     {
	       gimplify_conversion (&var0);
	       // Attempt to fill in any within var0 found ARRAY_REF's
	       // element size from corresponding op embedded ARRAY_REF,
	       // if unsuccessful, just punt.
	     }  */
	while (POINTER_TYPE_P (type))
	  type = TREE_TYPE (type);
	if (int_size_in_bytes (type) < 0)
	  return false;

	*var = var0;
	*off = off0;
	return true;
      }

    case SSA_NAME:
      {
	if (SSA_NAME_OCCURS_IN_ABNORMAL_PHI (op0))
	  return false;

	gimple *def_stmt = SSA_NAME_DEF_STMT (op0);
	enum tree_code subcode;

	if (gimple_code (def_stmt) != GIMPLE_ASSIGN)
	  return false;

	var0 = gimple_assign_rhs1 (def_stmt);
	subcode = gimple_assign_rhs_code (def_stmt);
	var1 = gimple_assign_rhs2 (def_stmt);

	return split_constant_offset_1 (type, var0, subcode, var1, var, off);
      }
    CASE_CONVERT:
      {
	/* We must not introduce undefined overflow, and we must not change the value.
	   Hence we're okay if the inner type doesn't overflow to start with
	   (pointer or signed), the outer type also is an integer or pointer
	   and the outer precision is at least as large as the inner.  */
	tree itype = TREE_TYPE (op0);
	if ((POINTER_TYPE_P (itype)
	     || (INTEGRAL_TYPE_P (itype) && TYPE_OVERFLOW_UNDEFINED (itype)))
	    && TYPE_PRECISION (type) >= TYPE_PRECISION (itype)
	    && (POINTER_TYPE_P (type) || INTEGRAL_TYPE_P (type)))
	  {
	    split_constant_offset (op0, &var0, off);
	    *var = fold_convert (type, var0);
	    return true;
	  }
	return false;
      }

    default:
      return false;
    }
}

/* Expresses EXP as VAR + OFF, where off is a constant.  The type of OFF
   will be ssizetype.  */

void
split_constant_offset (tree exp, tree *var, tree *off)
{
  tree type = TREE_TYPE (exp), otype, op0, op1, e, o;
  enum tree_code code;

  *var = exp;
  *off = ssize_int (0);
  STRIP_NOPS (exp);

  if (tree_is_chrec (exp)
      || get_gimple_rhs_class (TREE_CODE (exp)) == GIMPLE_TERNARY_RHS)
    return;

  otype = TREE_TYPE (exp);
  code = TREE_CODE (exp);
  extract_ops_from_tree (exp, &code, &op0, &op1);
  if (split_constant_offset_1 (otype, op0, code, op1, &e, &o))
    {
      *var = fold_convert (type, e);
      *off = o;
    }
}

/* Returns the address ADDR of an object in a canonical shape (without nop
   casts, and with type of pointer to the object).  */

static tree
canonicalize_base_object_address (tree addr)
{
  tree orig = addr;

  STRIP_NOPS (addr);

  /* The base address may be obtained by casting from integer, in that case
     keep the cast.  */
  if (!POINTER_TYPE_P (TREE_TYPE (addr)))
    return orig;

  if (TREE_CODE (addr) != ADDR_EXPR)
    return addr;

  return build_fold_addr_expr (TREE_OPERAND (addr, 0));
}

/* Analyze the behavior of memory reference REF.  There are two modes:

   - BB analysis.  In this case we simply split the address into base,
     init and offset components, without reference to any containing loop.
     The resulting base and offset are general expressions and they can
     vary arbitrarily from one iteration of the containing loop to the next.
     The step is always zero.

   - loop analysis.  In this case we analyze the reference both wrt LOOP
     and on the basis that the reference occurs (is "used") in LOOP;
     see the comment above analyze_scalar_evolution_in_loop for more
     information about this distinction.  The base, init, offset and
     step fields are all invariant in LOOP.

   Perform BB analysis if LOOP is null, or if LOOP is the function's
   dummy outermost loop.  In other cases perform loop analysis.

   Return true if the analysis succeeded and store the results in DRB if so.
   BB analysis can only fail for bitfield or reversed-storage accesses.  */

bool
dr_analyze_innermost (innermost_loop_behavior *drb, tree ref,
		      struct loop *loop)
{
  HOST_WIDE_INT pbitsize, pbitpos;
  tree base, poffset;
  machine_mode pmode;
  int punsignedp, preversep, pvolatilep;
  affine_iv base_iv, offset_iv;
  tree init, dinit, step;
  bool in_loop = (loop && loop->num);

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "analyze_innermost: ");

  base = get_inner_reference (ref, &pbitsize, &pbitpos, &poffset, &pmode,
			      &punsignedp, &preversep, &pvolatilep);
  gcc_assert (base != NULL_TREE);

  if (pbitpos % BITS_PER_UNIT != 0)
    {
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "failed: bit offset alignment.\n");
      return false;
    }

  if (preversep)
    {
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "failed: reverse storage order.\n");
      return false;
    }

  /* Calculate the alignment and misalignment for the inner reference.  */
  unsigned int HOST_WIDE_INT base_misalignment;
  unsigned int base_alignment;
  get_object_alignment_1 (base, &base_alignment, &base_misalignment);

  /* There are no bitfield references remaining in BASE, so the values
     we got back must be whole bytes.  */
  gcc_assert (base_alignment % BITS_PER_UNIT == 0
	      && base_misalignment % BITS_PER_UNIT == 0);
  base_alignment /= BITS_PER_UNIT;
  base_misalignment /= BITS_PER_UNIT;

  if (TREE_CODE (base) == MEM_REF)
    {
      if (!integer_zerop (TREE_OPERAND (base, 1)))
	{
	  /* Subtract MOFF from the base and add it to POFFSET instead.
	     Adjust the misalignment to reflect the amount we subtracted.  */
	  offset_int moff = mem_ref_offset (base);
	  base_misalignment -= moff.to_short_addr ();
	  tree mofft = wide_int_to_tree (sizetype, moff);
	  if (!poffset)
	    poffset = mofft;
	  else
	    poffset = size_binop (PLUS_EXPR, poffset, mofft);
	}
      base = TREE_OPERAND (base, 0);
    }
  else
    base = build_fold_addr_expr (base);

  if (in_loop)
    {
      if (!simple_iv (loop, loop, base, &base_iv, true))
        {
	  if (dump_file && (dump_flags & TDF_DETAILS))
	    fprintf (dump_file, "failed: evolution of base is not affine.\n");
	  return false;
        }
    }
  else
    {
      base_iv.base = base;
      base_iv.step = ssize_int (0);
      base_iv.no_overflow = true;
    }

  if (!poffset)
    {
      offset_iv.base = ssize_int (0);
      offset_iv.step = ssize_int (0);
    }
  else
    {
      if (!in_loop)
        {
          offset_iv.base = poffset;
          offset_iv.step = ssize_int (0);
        }
      else if (!simple_iv (loop, loop, poffset, &offset_iv, true))
        {
	  if (dump_file && (dump_flags & TDF_DETAILS))
	    fprintf (dump_file, "failed: evolution of offset is not affine.\n");
	  return false;
        }
    }

  init = ssize_int (pbitpos / BITS_PER_UNIT);

  /* Subtract any constant component from the base and add it to INIT instead.
     Adjust the misalignment to reflect the amount we subtracted.  */
  split_constant_offset (base_iv.base, &base_iv.base, &dinit);
  init = size_binop (PLUS_EXPR, init, dinit);
  base_misalignment -= TREE_INT_CST_LOW (dinit);

  split_constant_offset (offset_iv.base, &offset_iv.base, &dinit);
  init = size_binop (PLUS_EXPR, init, dinit);

  step = size_binop (PLUS_EXPR,
		     fold_convert (ssizetype, base_iv.step),
		     fold_convert (ssizetype, offset_iv.step));

  base = canonicalize_base_object_address (base_iv.base);

  /* See if get_pointer_alignment can guarantee a higher alignment than
     the one we calculated above.  */
  unsigned int HOST_WIDE_INT alt_misalignment;
  unsigned int alt_alignment;
  get_pointer_alignment_1 (base, &alt_alignment, &alt_misalignment);

  /* As above, these values must be whole bytes.  */
  gcc_assert (alt_alignment % BITS_PER_UNIT == 0
	      && alt_misalignment % BITS_PER_UNIT == 0);
  alt_alignment /= BITS_PER_UNIT;
  alt_misalignment /= BITS_PER_UNIT;

  if (base_alignment < alt_alignment)
    {
      base_alignment = alt_alignment;
      base_misalignment = alt_misalignment;
    }

  drb->base_address = base;
  drb->offset = fold_convert (ssizetype, offset_iv.base);
  drb->init = init;
  drb->step = step;
  drb->base_alignment = base_alignment;
  drb->base_misalignment = base_misalignment & (base_alignment - 1);
  drb->offset_alignment = highest_pow2_factor (offset_iv.base);
  drb->step_alignment = highest_pow2_factor (step);

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "success.\n");

  return true;
}

/* Return true if OP is a valid component reference for a DR access
   function.  This accepts a subset of what handled_component_p accepts.  */

static bool
access_fn_component_p (tree op)
{
  switch (TREE_CODE (op))
    {
    case REALPART_EXPR:
    case IMAGPART_EXPR:
    case ARRAY_REF:
      return true;

    case COMPONENT_REF:
      return TREE_CODE (TREE_TYPE (TREE_OPERAND (op, 0))) == RECORD_TYPE;

    default:
      return false;
    }
}

/* Determines the base object and the list of indices of memory reference
   DR, analyzed in LOOP and instantiated in loop nest NEST.  */

static void
dr_analyze_indices (struct data_reference *dr, loop_p nest, loop_p loop)
{
  vec<tree> access_fns = vNULL;
  tree ref, op;
  tree base, off, access_fn;
  basic_block before_loop;

  /* If analyzing a basic-block there are no indices to analyze
     and thus no access functions.  */
  if (!nest)
    {
      DR_BASE_OBJECT (dr) = DR_REF (dr);
      DR_ACCESS_FNS (dr).create (0);
      return;
    }

  ref = DR_REF (dr);
  before_loop = block_before_loop (nest);

  /* REALPART_EXPR and IMAGPART_EXPR can be handled like accesses
     into a two element array with a constant index.  The base is
     then just the immediate underlying object.  */
  if (TREE_CODE (ref) == REALPART_EXPR)
    {
      ref = TREE_OPERAND (ref, 0);
      access_fns.safe_push (integer_zero_node);
    }
  else if (TREE_CODE (ref) == IMAGPART_EXPR)
    {
      ref = TREE_OPERAND (ref, 0);
      access_fns.safe_push (integer_one_node);
    }

  /* Analyze access functions of dimensions we know to be independent.
     The list of component references handled here should be kept in
     sync with access_fn_component_p.  */
  while (handled_component_p (ref))
    {
      if (TREE_CODE (ref) == ARRAY_REF)
	{
	  op = TREE_OPERAND (ref, 1);
	  access_fn = analyze_scalar_evolution (loop, op);
	  access_fn = instantiate_scev (before_loop, loop, access_fn);
	  access_fns.safe_push (access_fn);
	}
      else if (TREE_CODE (ref) == COMPONENT_REF
	       && TREE_CODE (TREE_TYPE (TREE_OPERAND (ref, 0))) == RECORD_TYPE)
	{
	  /* For COMPONENT_REFs of records (but not unions!) use the
	     FIELD_DECL offset as constant access function so we can
	     disambiguate a[i].f1 and a[i].f2.  */
	  tree off = component_ref_field_offset (ref);
	  off = size_binop (PLUS_EXPR,
			    size_binop (MULT_EXPR,
					fold_convert (bitsizetype, off),
					bitsize_int (BITS_PER_UNIT)),
			    DECL_FIELD_BIT_OFFSET (TREE_OPERAND (ref, 1)));
	  access_fns.safe_push (off);
	}
      else
	/* If we have an unhandled component we could not translate
	   to an access function stop analyzing.  We have determined
	   our base object in this case.  */
	break;

      ref = TREE_OPERAND (ref, 0);
    }

  /* If the address operand of a MEM_REF base has an evolution in the
     analyzed nest, add it as an additional independent access-function.  */
  if (TREE_CODE (ref) == MEM_REF)
    {
      op = TREE_OPERAND (ref, 0);
      access_fn = analyze_scalar_evolution (loop, op);
      access_fn = instantiate_scev (before_loop, loop, access_fn);
      if (TREE_CODE (access_fn) == POLYNOMIAL_CHREC)
	{
	  tree orig_type;
	  tree memoff = TREE_OPERAND (ref, 1);
	  base = initial_condition (access_fn);
	  orig_type = TREE_TYPE (base);
	  STRIP_USELESS_TYPE_CONVERSION (base);
	  split_constant_offset (base, &base, &off);
	  STRIP_USELESS_TYPE_CONVERSION (base);
	  /* Fold the MEM_REF offset into the evolutions initial
	     value to make more bases comparable.  */
	  if (!integer_zerop (memoff))
	    {
	      off = size_binop (PLUS_EXPR, off,
				fold_convert (ssizetype, memoff));
	      memoff = build_int_cst (TREE_TYPE (memoff), 0);
	    }
	  /* Adjust the offset so it is a multiple of the access type
	     size and thus we separate bases that can possibly be used
	     to produce partial overlaps (which the access_fn machinery
	     cannot handle).  */
	  wide_int rem;
	  if (TYPE_SIZE_UNIT (TREE_TYPE (ref))
	      && TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (ref))) == INTEGER_CST
	      && !integer_zerop (TYPE_SIZE_UNIT (TREE_TYPE (ref))))
	    rem = wi::mod_trunc (off, TYPE_SIZE_UNIT (TREE_TYPE (ref)), SIGNED);
	  else
	    /* If we can't compute the remainder simply force the initial
	       condition to zero.  */
	    rem = off;
	  off = wide_int_to_tree (ssizetype, wi::sub (off, rem));
	  memoff = wide_int_to_tree (TREE_TYPE (memoff), rem);
	  /* And finally replace the initial condition.  */
	  access_fn = chrec_replace_initial_condition
	      (access_fn, fold_convert (orig_type, off));
	  /* ???  This is still not a suitable base object for
	     dr_may_alias_p - the base object needs to be an
	     access that covers the object as whole.  With
	     an evolution in the pointer this cannot be
	     guaranteed.
	     As a band-aid, mark the access so we can special-case
	     it in dr_may_alias_p.  */
	  tree old = ref;
	  ref = fold_build2_loc (EXPR_LOCATION (ref),
				 MEM_REF, TREE_TYPE (ref),
				 base, memoff);
	  MR_DEPENDENCE_CLIQUE (ref) = MR_DEPENDENCE_CLIQUE (old);
	  MR_DEPENDENCE_BASE (ref) = MR_DEPENDENCE_BASE (old);
	  DR_UNCONSTRAINED_BASE (dr) = true;
	  access_fns.safe_push (access_fn);
	}
    }
  else if (DECL_P (ref))
    {
      /* Canonicalize DR_BASE_OBJECT to MEM_REF form.  */
      ref = build2 (MEM_REF, TREE_TYPE (ref),
		    build_fold_addr_expr (ref),
		    build_int_cst (reference_alias_ptr_type (ref), 0));
    }

  DR_BASE_OBJECT (dr) = ref;
  DR_ACCESS_FNS (dr) = access_fns;
}

/* Extracts the alias analysis information from the memory reference DR.  */

static void
dr_analyze_alias (struct data_reference *dr)
{
  tree ref = DR_REF (dr);
  tree base = get_base_address (ref), addr;

  if (INDIRECT_REF_P (base)
      || TREE_CODE (base) == MEM_REF)
    {
      addr = TREE_OPERAND (base, 0);
      if (TREE_CODE (addr) == SSA_NAME)
	DR_PTR_INFO (dr) = SSA_NAME_PTR_INFO (addr);
    }
}

/* Frees data reference DR.  */

void
free_data_ref (data_reference_p dr)
{
  DR_ACCESS_FNS (dr).release ();
  free (dr);
}

/* Analyze memory reference MEMREF, which is accessed in STMT.
   The reference is a read if IS_READ is true, otherwise it is a write.
   IS_CONDITIONAL_IN_STMT indicates that the reference is conditional
   within STMT, i.e. that it might not occur even if STMT is executed
   and runs to completion.

   Return the data_reference description of MEMREF.  NEST is the outermost
   loop in which the reference should be instantiated, LOOP is the loop
   in which the data reference should be analyzed.  */

struct data_reference *
create_data_ref (loop_p nest, loop_p loop, tree memref, gimple *stmt,
		 bool is_read, bool is_conditional_in_stmt)
{
  struct data_reference *dr;

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      fprintf (dump_file, "Creating dr for ");
      print_generic_expr (dump_file, memref, TDF_SLIM);
      fprintf (dump_file, "\n");
    }

  dr = XCNEW (struct data_reference);
  DR_STMT (dr) = stmt;
  DR_REF (dr) = memref;
  DR_IS_READ (dr) = is_read;
  DR_IS_CONDITIONAL_IN_STMT (dr) = is_conditional_in_stmt;

  dr_analyze_innermost (&DR_INNERMOST (dr), memref,
			nest != NULL ? loop : NULL);
  dr_analyze_indices (dr, nest, loop);
  dr_analyze_alias (dr);

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      unsigned i;
      fprintf (dump_file, "\tbase_address: ");
      print_generic_expr (dump_file, DR_BASE_ADDRESS (dr), TDF_SLIM);
      fprintf (dump_file, "\n\toffset from base address: ");
      print_generic_expr (dump_file, DR_OFFSET (dr), TDF_SLIM);
      fprintf (dump_file, "\n\tconstant offset from base address: ");
      print_generic_expr (dump_file, DR_INIT (dr), TDF_SLIM);
      fprintf (dump_file, "\n\tstep: ");
      print_generic_expr (dump_file, DR_STEP (dr), TDF_SLIM);
      fprintf (dump_file, "\n\tbase alignment: %d", DR_BASE_ALIGNMENT (dr));
      fprintf (dump_file, "\n\tbase misalignment: %d",
	       DR_BASE_MISALIGNMENT (dr));
      fprintf (dump_file, "\n\toffset alignment: %d",
	       DR_OFFSET_ALIGNMENT (dr));
      fprintf (dump_file, "\n\tstep alignment: %d", DR_STEP_ALIGNMENT (dr));
      fprintf (dump_file, "\n\tbase_object: ");
      print_generic_expr (dump_file, DR_BASE_OBJECT (dr), TDF_SLIM);
      fprintf (dump_file, "\n");
      for (i = 0; i < DR_NUM_DIMENSIONS (dr); i++)
	{
	  fprintf (dump_file, "\tAccess function %d: ", i);
	  print_generic_stmt (dump_file, DR_ACCESS_FN (dr, i), TDF_SLIM);
	}
    }

  return dr;
}

/*  A helper function computes order between two tree epxressions T1 and T2.
    This is used in comparator functions sorting objects based on the order
    of tree expressions.  The function returns -1, 0, or 1.  */

int
data_ref_compare_tree (tree t1, tree t2)
{
  int i, cmp;
  enum tree_code code;
  char tclass;

  if (t1 == t2)
    return 0;
  if (t1 == NULL)
    return -1;
  if (t2 == NULL)
    return 1;

  STRIP_NOPS (t1);
  STRIP_NOPS (t2);

  if (TREE_CODE (t1) != TREE_CODE (t2))
    return TREE_CODE (t1) < TREE_CODE (t2) ? -1 : 1;

  code = TREE_CODE (t1);
  switch (code)
    {
    /* For const values, we can just use hash values for comparisons.  */
    case INTEGER_CST:
    case REAL_CST:
    case FIXED_CST:
    case STRING_CST:
    case COMPLEX_CST:
    case VECTOR_CST:
      {
	hashval_t h1 = iterative_hash_expr (t1, 0);
	hashval_t h2 = iterative_hash_expr (t2, 0);
	if (h1 != h2)
	  return h1 < h2 ? -1 : 1;
	break;
      }

    case SSA_NAME:
      cmp = data_ref_compare_tree (SSA_NAME_VAR (t1), SSA_NAME_VAR (t2));
      if (cmp != 0)
	return cmp;

      if (SSA_NAME_VERSION (t1) != SSA_NAME_VERSION (t2))
	return SSA_NAME_VERSION (t1) < SSA_NAME_VERSION (t2) ? -1 : 1;
      break;

    default:
      tclass = TREE_CODE_CLASS (code);

      /* For var-decl, we could compare their UIDs.  */
      if (tclass == tcc_declaration)
	{
	  if (DECL_UID (t1) != DECL_UID (t2))
	    return DECL_UID (t1) < DECL_UID (t2) ? -1 : 1;
	  break;
	}

      /* For expressions with operands, compare their operands recursively.  */
      for (i = TREE_OPERAND_LENGTH (t1) - 1; i >= 0; --i)
	{
	  cmp = data_ref_compare_tree (TREE_OPERAND (t1, i),
				       TREE_OPERAND (t2, i));
	  if (cmp != 0)
	    return cmp;
	}
    }

  return 0;
}

/* Return TRUE it's possible to resolve data dependence DDR by runtime alias
   check.  */

bool
runtime_alias_check_p (ddr_p ddr, struct loop *loop, bool speed_p)
{
  if (dump_enabled_p ())
    {
      dump_printf (MSG_NOTE, "consider run-time aliasing test between ");
      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (DDR_A (ddr)));
      dump_printf (MSG_NOTE,  " and ");
      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (DDR_B (ddr)));
      dump_printf (MSG_NOTE, "\n");
    }

  if (!speed_p)
    {
      if (dump_enabled_p ())
	dump_printf (MSG_MISSED_OPTIMIZATION,
		     "runtime alias check not supported when optimizing "
		     "for size.\n");
      return false;
    }

  /* FORNOW: We don't support versioning with outer-loop in either
     vectorization or loop distribution.  */
  if (loop != NULL && loop->inner != NULL)
    {
      if (dump_enabled_p ())
	dump_printf (MSG_MISSED_OPTIMIZATION,
		     "runtime alias check not supported for outer loop.\n");
      return false;
    }

  /* FORNOW: We don't support creating runtime alias tests for non-constant
     step.  */
  if (TREE_CODE (DR_STEP (DDR_A (ddr))) != INTEGER_CST
      || TREE_CODE (DR_STEP (DDR_B (ddr))) != INTEGER_CST)
    {
      if (dump_enabled_p ())
	dump_printf (MSG_MISSED_OPTIMIZATION,
                     "runtime alias check not supported for non-constant "
		     "step\n");
      return false;
    }

  return true;
}

/* Operator == between two dr_with_seg_len objects.

   This equality operator is used to make sure two data refs
   are the same one so that we will consider to combine the
   aliasing checks of those two pairs of data dependent data
   refs.  */

static bool
operator == (const dr_with_seg_len& d1,
	     const dr_with_seg_len& d2)
{
  return operand_equal_p (DR_BASE_ADDRESS (d1.dr),
			  DR_BASE_ADDRESS (d2.dr), 0)
	   && data_ref_compare_tree (DR_OFFSET (d1.dr), DR_OFFSET (d2.dr)) == 0
	   && data_ref_compare_tree (DR_INIT (d1.dr), DR_INIT (d2.dr)) == 0
	   && data_ref_compare_tree (d1.seg_len, d2.seg_len) == 0;
}

/* Comparison function for sorting objects of dr_with_seg_len_pair_t
   so that we can combine aliasing checks in one scan.  */

static int
comp_dr_with_seg_len_pair (const void *pa_, const void *pb_)
{
  const dr_with_seg_len_pair_t* pa = (const dr_with_seg_len_pair_t *) pa_;
  const dr_with_seg_len_pair_t* pb = (const dr_with_seg_len_pair_t *) pb_;
  const dr_with_seg_len &a1 = pa->first, &a2 = pa->second;
  const dr_with_seg_len &b1 = pb->first, &b2 = pb->second;

  /* For DR pairs (a, b) and (c, d), we only consider to merge the alias checks
     if a and c have the same basic address snd step, and b and d have the same
     address and step.  Therefore, if any a&c or b&d don't have the same address
     and step, we don't care the order of those two pairs after sorting.  */
  int comp_res;

  if ((comp_res = data_ref_compare_tree (DR_BASE_ADDRESS (a1.dr),
					 DR_BASE_ADDRESS (b1.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_BASE_ADDRESS (a2.dr),
					 DR_BASE_ADDRESS (b2.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_STEP (a1.dr),
					 DR_STEP (b1.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_STEP (a2.dr),
					 DR_STEP (b2.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_OFFSET (a1.dr),
					 DR_OFFSET (b1.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_INIT (a1.dr),
					 DR_INIT (b1.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_OFFSET (a2.dr),
					 DR_OFFSET (b2.dr))) != 0)
    return comp_res;
  if ((comp_res = data_ref_compare_tree (DR_INIT (a2.dr),
					 DR_INIT (b2.dr))) != 0)
    return comp_res;

  return 0;
}

/* Merge alias checks recorded in ALIAS_PAIRS and remove redundant ones.
   FACTOR is number of iterations that each data reference is accessed.

   Basically, for each pair of dependent data refs store_ptr_0 & load_ptr_0,
   we create an expression:

   ((store_ptr_0 + store_segment_length_0) <= load_ptr_0)
   || (load_ptr_0 + load_segment_length_0) <= store_ptr_0))

   for aliasing checks.  However, in some cases we can decrease the number
   of checks by combining two checks into one.  For example, suppose we have
   another pair of data refs store_ptr_0 & load_ptr_1, and if the following
   condition is satisfied:

   load_ptr_0 < load_ptr_1  &&
   load_ptr_1 - load_ptr_0 - load_segment_length_0 < store_segment_length_0

   (this condition means, in each iteration of vectorized loop, the accessed
   memory of store_ptr_0 cannot be between the memory of load_ptr_0 and
   load_ptr_1.)

   we then can use only the following expression to finish the alising checks
   between store_ptr_0 & load_ptr_0 and store_ptr_0 & load_ptr_1:

   ((store_ptr_0 + store_segment_length_0) <= load_ptr_0)
   || (load_ptr_1 + load_segment_length_1 <= store_ptr_0))

   Note that we only consider that load_ptr_0 and load_ptr_1 have the same
   basic address.  */

void
prune_runtime_alias_test_list (vec<dr_with_seg_len_pair_t> *alias_pairs,
			       unsigned HOST_WIDE_INT factor)
{
  /* Sort the collected data ref pairs so that we can scan them once to
     combine all possible aliasing checks.  */
  alias_pairs->qsort (comp_dr_with_seg_len_pair);

  /* Scan the sorted dr pairs and check if we can combine alias checks
     of two neighboring dr pairs.  */
  for (size_t i = 1; i < alias_pairs->length (); ++i)
    {
      /* Deal with two ddrs (dr_a1, dr_b1) and (dr_a2, dr_b2).  */
      dr_with_seg_len *dr_a1 = &(*alias_pairs)[i-1].first,
		      *dr_b1 = &(*alias_pairs)[i-1].second,
		      *dr_a2 = &(*alias_pairs)[i].first,
		      *dr_b2 = &(*alias_pairs)[i].second;

      /* Remove duplicate data ref pairs.  */
      if (*dr_a1 == *dr_a2 && *dr_b1 == *dr_b2)
	{
	  if (dump_enabled_p ())
	    {
	      dump_printf (MSG_NOTE, "found equal ranges ");
	      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_a1->dr));
	      dump_printf (MSG_NOTE,  ", ");
	      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_b1->dr));
	      dump_printf (MSG_NOTE,  " and ");
	      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_a2->dr));
	      dump_printf (MSG_NOTE,  ", ");
	      dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_b2->dr));
	      dump_printf (MSG_NOTE, "\n");
	    }
	  alias_pairs->ordered_remove (i--);
	  continue;
	}

      if (*dr_a1 == *dr_a2 || *dr_b1 == *dr_b2)
	{
	  /* We consider the case that DR_B1 and DR_B2 are same memrefs,
	     and DR_A1 and DR_A2 are two consecutive memrefs.  */
	  if (*dr_a1 == *dr_a2)
	    {
	      std::swap (dr_a1, dr_b1);
	      std::swap (dr_a2, dr_b2);
	    }

	  if (!operand_equal_p (DR_BASE_ADDRESS (dr_a1->dr),
				DR_BASE_ADDRESS (dr_a2->dr), 0)
	      || !operand_equal_p (DR_OFFSET (dr_a1->dr),
				   DR_OFFSET (dr_a2->dr), 0)
	      || !tree_fits_shwi_p (DR_INIT (dr_a1->dr))
	      || !tree_fits_shwi_p (DR_INIT (dr_a2->dr)))
	    continue;

	  /* Only merge const step data references.  */
	  if (TREE_CODE (DR_STEP (dr_a1->dr)) != INTEGER_CST
	      || TREE_CODE (DR_STEP (dr_a2->dr)) != INTEGER_CST)
	    continue;

	  /* DR_A1 and DR_A2 must goes in the same direction.  */
	  if (tree_int_cst_compare (DR_STEP (dr_a1->dr), size_zero_node)
	      != tree_int_cst_compare (DR_STEP (dr_a2->dr), size_zero_node))
	    continue;

	  bool neg_step
	    = (tree_int_cst_compare (DR_STEP (dr_a1->dr), size_zero_node) < 0);

	  /* We need to compute merged segment length at compilation time for
	     dr_a1 and dr_a2, which is impossible if either one has non-const
	     segment length.  */
	  if ((!tree_fits_uhwi_p (dr_a1->seg_len)
	       || !tree_fits_uhwi_p (dr_a2->seg_len))
	      && tree_int_cst_compare (DR_STEP (dr_a1->dr),
				       DR_STEP (dr_a2->dr)) != 0)
	    continue;

	  /* Make sure dr_a1 starts left of dr_a2.  */
	  if (tree_int_cst_lt (DR_INIT (dr_a2->dr), DR_INIT (dr_a1->dr)))
	    std::swap (*dr_a1, *dr_a2);

	  bool do_remove = false;
	  wide_int diff = wi::sub (DR_INIT (dr_a2->dr), DR_INIT (dr_a1->dr));
	  wide_int min_seg_len_b;
	  tree new_seg_len;

	  if (TREE_CODE (dr_b1->seg_len) == INTEGER_CST)
	    min_seg_len_b = wi::abs (dr_b1->seg_len);
	  else
	    min_seg_len_b = wi::mul (factor, wi::abs (DR_STEP (dr_b1->dr)));

	  /* Now we try to merge alias check dr_a1 & dr_b and dr_a2 & dr_b.

	     Case A:
	       check if the following condition is satisfied:

	       DIFF - SEGMENT_LENGTH_A < SEGMENT_LENGTH_B

	       where DIFF = DR_A2_INIT - DR_A1_INIT.  However,
	       SEGMENT_LENGTH_A or SEGMENT_LENGTH_B may not be constant so we
	       have to make a best estimation.  We can get the minimum value
	       of SEGMENT_LENGTH_B as a constant, represented by MIN_SEG_LEN_B,
	       then either of the following two conditions can guarantee the
	       one above:

	       1: DIFF <= MIN_SEG_LEN_B
	       2: DIFF - SEGMENT_LENGTH_A < MIN_SEG_LEN_B
		  Because DIFF - SEGMENT_LENGTH_A is done in sizetype, we need
		  to take care of wrapping behavior in it.

	     Case B:
	       If the left segment does not extend beyond the start of the
	       right segment the new segment length is that of the right
	       plus the segment distance.  The condition is like:

	       DIFF >= SEGMENT_LENGTH_A   ;SEGMENT_LENGTH_A is a constant.

	     Note 1: Case A.2 and B combined together effectively merges every
	     dr_a1 & dr_b and dr_a2 & dr_b when SEGMENT_LENGTH_A is const.

	     Note 2: Above description is based on positive DR_STEP, we need to
	     take care of negative DR_STEP for wrapping behavior.  See PR80815
	     for more information.  */
	  if (neg_step)
	    {
	      /* Adjust diff according to access size of both references.  */
	      tree size_a1 = TYPE_SIZE_UNIT (TREE_TYPE (DR_REF (dr_a1->dr)));
	      tree size_a2 = TYPE_SIZE_UNIT (TREE_TYPE (DR_REF (dr_a2->dr)));
	      diff = wi::add (diff, wi::sub (size_a2, size_a1));
	      /* Case A.1.  */
	      if (wi::leu_p (diff, min_seg_len_b)
		  /* Case A.2 and B combined.  */
		  || (tree_fits_uhwi_p (dr_a2->seg_len)))
		{
		  if (tree_fits_uhwi_p (dr_a1->seg_len)
		      && tree_fits_uhwi_p (dr_a2->seg_len))
		    new_seg_len
		      = wide_int_to_tree (sizetype,
					  wi::umin (wi::sub (dr_a1->seg_len,
							     diff),
						    dr_a2->seg_len));
		  else
		    new_seg_len
		      = size_binop (MINUS_EXPR, dr_a2->seg_len,
				    wide_int_to_tree (sizetype, diff));

		  dr_a2->seg_len = new_seg_len;
		  do_remove = true;
		}
	    }
	  else
	    {
	      /* Case A.1.  */
	      if (wi::leu_p (diff, min_seg_len_b)
		  /* Case A.2 and B combined.  */
		  || (tree_fits_uhwi_p (dr_a1->seg_len)))
		{
		  if (tree_fits_uhwi_p (dr_a1->seg_len)
		      && tree_fits_uhwi_p (dr_a2->seg_len))
		    new_seg_len
		      = wide_int_to_tree (sizetype,
					  wi::umax (wi::add (dr_a2->seg_len,
							     diff),
						    dr_a1->seg_len));
		  else
		    new_seg_len
		      = size_binop (PLUS_EXPR, dr_a2->seg_len,
				    wide_int_to_tree (sizetype, diff));

		  dr_a1->seg_len = new_seg_len;
		  do_remove = true;
		}
	    }

	  if (do_remove)
	    {
	      if (dump_enabled_p ())
		{
		  dump_printf (MSG_NOTE, "merging ranges for ");
		  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_a1->dr));
		  dump_printf (MSG_NOTE,  ", ");
		  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_b1->dr));
		  dump_printf (MSG_NOTE,  " and ");
		  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_a2->dr));
		  dump_printf (MSG_NOTE,  ", ");
		  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_b2->dr));
		  dump_printf (MSG_NOTE, "\n");
		}
	      alias_pairs->ordered_remove (neg_step ? i - 1 : i);
	      i--;
	    }
	}
    }
}

/* Given LOOP's two data references and segment lengths described by DR_A
   and DR_B, create expression checking if the two addresses ranges intersect
   with each other based on index of the two addresses.  This can only be
   done if DR_A and DR_B referring to the same (array) object and the index
   is the only difference.  For example:

                       DR_A                           DR_B
      data-ref         arr[i]                         arr[j]
      base_object      arr                            arr
      index            {i_0, +, 1}_loop               {j_0, +, 1}_loop

   The addresses and their index are like:

        |<- ADDR_A    ->|          |<- ADDR_B    ->|
     ------------------------------------------------------->
        |   |   |   |   |          |   |   |   |   |
     ------------------------------------------------------->
        i_0 ...         i_0+4      j_0 ...         j_0+4

   We can create expression based on index rather than address:

     (i_0 + 4 < j_0 || j_0 + 4 < i_0)

   Note evolution step of index needs to be considered in comparison.  */

static bool
create_intersect_range_checks_index (struct loop *loop, tree *cond_expr,
				     const dr_with_seg_len& dr_a,
				     const dr_with_seg_len& dr_b)
{
  if (integer_zerop (DR_STEP (dr_a.dr))
      || integer_zerop (DR_STEP (dr_b.dr))
      || DR_NUM_DIMENSIONS (dr_a.dr) != DR_NUM_DIMENSIONS (dr_b.dr))
    return false;

  if (!tree_fits_uhwi_p (dr_a.seg_len) || !tree_fits_uhwi_p (dr_b.seg_len))
    return false;

  if (!tree_fits_shwi_p (DR_STEP (dr_a.dr)))
    return false;

  if (!operand_equal_p (DR_BASE_OBJECT (dr_a.dr), DR_BASE_OBJECT (dr_b.dr), 0))
    return false;

  if (!operand_equal_p (DR_STEP (dr_a.dr), DR_STEP (dr_b.dr), 0))
    return false;

  gcc_assert (TREE_CODE (DR_STEP (dr_a.dr)) == INTEGER_CST);

  bool neg_step = tree_int_cst_compare (DR_STEP (dr_a.dr), size_zero_node) < 0;
  unsigned HOST_WIDE_INT abs_step
    = absu_hwi (tree_to_shwi (DR_STEP (dr_a.dr)));

  unsigned HOST_WIDE_INT seg_len1 = tree_to_uhwi (dr_a.seg_len);
  unsigned HOST_WIDE_INT seg_len2 = tree_to_uhwi (dr_b.seg_len);
  /* Infer the number of iterations with which the memory segment is accessed
     by DR.  In other words, alias is checked if memory segment accessed by
     DR_A in some iterations intersect with memory segment accessed by DR_B
     in the same amount iterations.
     Note segnment length is a linear function of number of iterations with
     DR_STEP as the coefficient.  */
  unsigned HOST_WIDE_INT niter_len1 = (seg_len1 + abs_step - 1) / abs_step;
  unsigned HOST_WIDE_INT niter_len2 = (seg_len2 + abs_step - 1) / abs_step;

  unsigned int i;
  for (i = 0; i < DR_NUM_DIMENSIONS (dr_a.dr); i++)
    {
      tree access1 = DR_ACCESS_FN (dr_a.dr, i);
      tree access2 = DR_ACCESS_FN (dr_b.dr, i);
      /* Two indices must be the same if they are not scev, or not scev wrto
	 current loop being vecorized.  */
      if (TREE_CODE (access1) != POLYNOMIAL_CHREC
	  || TREE_CODE (access2) != POLYNOMIAL_CHREC
	  || CHREC_VARIABLE (access1) != (unsigned)loop->num
	  || CHREC_VARIABLE (access2) != (unsigned)loop->num)
	{
	  if (operand_equal_p (access1, access2, 0))
	    continue;

	  return false;
	}
      /* The two indices must have the same step.  */
      if (!operand_equal_p (CHREC_RIGHT (access1), CHREC_RIGHT (access2), 0))
	return false;

      tree idx_step = CHREC_RIGHT (access1);
      /* Index must have const step, otherwise DR_STEP won't be constant.  */
      gcc_assert (TREE_CODE (idx_step) == INTEGER_CST);
      /* Index must evaluate in the same direction as DR.  */
      gcc_assert (!neg_step || tree_int_cst_sign_bit (idx_step) == 1);

      tree min1 = CHREC_LEFT (access1);
      tree min2 = CHREC_LEFT (access2);
      if (!types_compatible_p (TREE_TYPE (min1), TREE_TYPE (min2)))
	return false;

      /* Ideally, alias can be checked against loop's control IV, but we
	 need to prove linear mapping between control IV and reference
	 index.  Although that should be true, we check against (array)
	 index of data reference.  Like segment length, index length is
	 linear function of the number of iterations with index_step as
	 the coefficient, i.e, niter_len * idx_step.  */
      tree idx_len1 = fold_build2 (MULT_EXPR, TREE_TYPE (min1), idx_step,
				   build_int_cst (TREE_TYPE (min1),
						  niter_len1));
      tree idx_len2 = fold_build2 (MULT_EXPR, TREE_TYPE (min2), idx_step,
				   build_int_cst (TREE_TYPE (min2),
						  niter_len2));
      tree max1 = fold_build2 (PLUS_EXPR, TREE_TYPE (min1), min1, idx_len1);
      tree max2 = fold_build2 (PLUS_EXPR, TREE_TYPE (min2), min2, idx_len2);
      /* Adjust ranges for negative step.  */
      if (neg_step)
	{
	  min1 = fold_build2 (MINUS_EXPR, TREE_TYPE (min1), max1, idx_step);
	  max1 = fold_build2 (MINUS_EXPR, TREE_TYPE (min1),
			      CHREC_LEFT (access1), idx_step);
	  min2 = fold_build2 (MINUS_EXPR, TREE_TYPE (min2), max2, idx_step);
	  max2 = fold_build2 (MINUS_EXPR, TREE_TYPE (min2),
			      CHREC_LEFT (access2), idx_step);
	}
      tree part_cond_expr
	= fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
	    fold_build2 (LE_EXPR, boolean_type_node, max1, min2),
	    fold_build2 (LE_EXPR, boolean_type_node, max2, min1));
      if (*cond_expr)
	*cond_expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
				  *cond_expr, part_cond_expr);
      else
	*cond_expr = part_cond_expr;
    }
  return true;
}

/* Given two data references and segment lengths described by DR_A and DR_B,
   create expression checking if the two addresses ranges intersect with
   each other:

     ((DR_A_addr_0 + DR_A_segment_length_0) <= DR_B_addr_0)
     || (DR_B_addr_0 + DER_B_segment_length_0) <= DR_A_addr_0))  */

static void
create_intersect_range_checks (struct loop *loop, tree *cond_expr,
			       const dr_with_seg_len& dr_a,
			       const dr_with_seg_len& dr_b)
{
  *cond_expr = NULL_TREE;
  if (create_intersect_range_checks_index (loop, cond_expr, dr_a, dr_b))
    return;

  tree segment_length_a = dr_a.seg_len;
  tree segment_length_b = dr_b.seg_len;
  tree addr_base_a = DR_BASE_ADDRESS (dr_a.dr);
  tree addr_base_b = DR_BASE_ADDRESS (dr_b.dr);
  tree offset_a = DR_OFFSET (dr_a.dr), offset_b = DR_OFFSET (dr_b.dr);

  offset_a = fold_build2 (PLUS_EXPR, TREE_TYPE (offset_a),
			  offset_a, DR_INIT (dr_a.dr));
  offset_b = fold_build2 (PLUS_EXPR, TREE_TYPE (offset_b),
			  offset_b, DR_INIT (dr_b.dr));
  addr_base_a = fold_build_pointer_plus (addr_base_a, offset_a);
  addr_base_b = fold_build_pointer_plus (addr_base_b, offset_b);

  tree seg_a_min = addr_base_a;
  tree seg_a_max = fold_build_pointer_plus (addr_base_a, segment_length_a);
  /* For negative step, we need to adjust address range by TYPE_SIZE_UNIT
     bytes, e.g., int a[3] -> a[1] range is [a+4, a+16) instead of
     [a, a+12) */
  if (tree_int_cst_compare (DR_STEP (dr_a.dr), size_zero_node) < 0)
    {
      tree unit_size = TYPE_SIZE_UNIT (TREE_TYPE (DR_REF (dr_a.dr)));
      seg_a_min = fold_build_pointer_plus (seg_a_max, unit_size);
      seg_a_max = fold_build_pointer_plus (addr_base_a, unit_size);
    }

  tree seg_b_min = addr_base_b;
  tree seg_b_max = fold_build_pointer_plus (addr_base_b, segment_length_b);
  if (tree_int_cst_compare (DR_STEP (dr_b.dr), size_zero_node) < 0)
    {
      tree unit_size = TYPE_SIZE_UNIT (TREE_TYPE (DR_REF (dr_b.dr)));
      seg_b_min = fold_build_pointer_plus (seg_b_max, unit_size);
      seg_b_max = fold_build_pointer_plus (addr_base_b, unit_size);
    }
  *cond_expr
    = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
	fold_build2 (LE_EXPR, boolean_type_node, seg_a_max, seg_b_min),
	fold_build2 (LE_EXPR, boolean_type_node, seg_b_max, seg_a_min));
}

/* Create a conditional expression that represents the run-time checks for
   overlapping of address ranges represented by a list of data references
   pairs passed in ALIAS_PAIRS.  Data references are in LOOP.  The returned
   COND_EXPR is the conditional expression to be used in the if statement
   that controls which version of the loop gets executed at runtime.  */

void
create_runtime_alias_checks (struct loop *loop,
			     vec<dr_with_seg_len_pair_t> *alias_pairs,
			     tree * cond_expr)
{
  tree part_cond_expr;

  for (size_t i = 0, s = alias_pairs->length (); i < s; ++i)
    {
      const dr_with_seg_len& dr_a = (*alias_pairs)[i].first;
      const dr_with_seg_len& dr_b = (*alias_pairs)[i].second;

      if (dump_enabled_p ())
	{
	  dump_printf (MSG_NOTE, "create runtime check for data references ");
	  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_a.dr));
	  dump_printf (MSG_NOTE, " and ");
	  dump_generic_expr (MSG_NOTE, TDF_SLIM, DR_REF (dr_b.dr));
	  dump_printf (MSG_NOTE, "\n");
	}

      /* Create condition expression for each pair data references.  */
      create_intersect_range_checks (loop, &part_cond_expr, dr_a, dr_b);
      if (*cond_expr)
	*cond_expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
				  *cond_expr, part_cond_expr);
      else
	*cond_expr = part_cond_expr;
    }
}

/* Check if OFFSET1 and OFFSET2 (DR_OFFSETs of some data-refs) are identical
   expressions.  */
static bool
dr_equal_offsets_p1 (tree offset1, tree offset2)
{
  bool res;

  STRIP_NOPS (offset1);
  STRIP_NOPS (offset2);

  if (offset1 == offset2)
    return true;

  if (TREE_CODE (offset1) != TREE_CODE (offset2)
      || (!BINARY_CLASS_P (offset1) && !UNARY_CLASS_P (offset1)))
    return false;

  res = dr_equal_offsets_p1 (TREE_OPERAND (offset1, 0),
                             TREE_OPERAND (offset2, 0));

  if (!res || !BINARY_CLASS_P (offset1))
    return res;

  res = dr_equal_offsets_p1 (TREE_OPERAND (offset1, 1),
                             TREE_OPERAND (offset2, 1));

  return res;
}

/* Check if DRA and DRB have equal offsets.  */
bool
dr_equal_offsets_p (struct data_reference *dra,
                    struct data_reference *drb)
{
  tree offset1, offset2;

  offset1 = DR_OFFSET (dra);
  offset2 = DR_OFFSET (drb);

  return dr_equal_offsets_p1 (offset1, offset2);
}

/* Returns true if FNA == FNB.  */

static bool
affine_function_equal_p (affine_fn fna, affine_fn fnb)
{
  unsigned i, n = fna.length ();

  if (n != fnb.length ())
    return false;

  for (i = 0; i < n; i++)
    if (!operand_equal_p (fna[i], fnb[i], 0))
      return false;

  return true;
}

/* If all the functions in CF are the same, returns one of them,
   otherwise returns NULL.  */

static affine_fn
common_affine_function (conflict_function *cf)
{
  unsigned i;
  affine_fn comm;

  if (!CF_NONTRIVIAL_P (cf))
    return affine_fn ();

  comm = cf->fns[0];

  for (i = 1; i < cf->n; i++)
    if (!affine_function_equal_p (comm, cf->fns[i]))
      return affine_fn ();

  return comm;
}

/* Returns the base of the affine function FN.  */

static tree
affine_function_base (affine_fn fn)
{
  return fn[0];
}

/* Returns true if FN is a constant.  */

static bool
affine_function_constant_p (affine_fn fn)
{
  unsigned i;
  tree coef;

  for (i = 1; fn.iterate (i, &coef); i++)
    if (!integer_zerop (coef))
      return false;

  return true;
}

/* Returns true if FN is the zero constant function.  */

static bool
affine_function_zero_p (affine_fn fn)
{
  return (integer_zerop (affine_function_base (fn))
	  && affine_function_constant_p (fn));
}

/* Returns a signed integer type with the largest precision from TA
   and TB.  */

static tree
signed_type_for_types (tree ta, tree tb)
{
  if (TYPE_PRECISION (ta) > TYPE_PRECISION (tb))
    return signed_type_for (ta);
  else
    return signed_type_for (tb);
}

/* Applies operation OP on affine functions FNA and FNB, and returns the
   result.  */

static affine_fn
affine_fn_op (enum tree_code op, affine_fn fna, affine_fn fnb)
{
  unsigned i, n, m;
  affine_fn ret;
  tree coef;

  if (fnb.length () > fna.length ())
    {
      n = fna.length ();
      m = fnb.length ();
    }
  else
    {
      n = fnb.length ();
      m = fna.length ();
    }

  ret.create (m);
  for (i = 0; i < n; i++)
    {
      tree type = signed_type_for_types (TREE_TYPE (fna[i]),
					 TREE_TYPE (fnb[i]));
      ret.quick_push (fold_build2 (op, type, fna[i], fnb[i]));
    }

  for (; fna.iterate (i, &coef); i++)
    ret.quick_push (fold_build2 (op, signed_type_for (TREE_TYPE (coef)),
				 coef, integer_zero_node));
  for (; fnb.iterate (i, &coef); i++)
    ret.quick_push (fold_build2 (op, signed_type_for (TREE_TYPE (coef)),
				 integer_zero_node, coef));

  return ret;
}

/* Returns the sum of affine functions FNA and FNB.  */

static affine_fn
affine_fn_plus (affine_fn fna, affine_fn fnb)
{
  return affine_fn_op (PLUS_EXPR, fna, fnb);
}

/* Returns the difference of affine functions FNA and FNB.  */

static affine_fn
affine_fn_minus (affine_fn fna, affine_fn fnb)
{
  return affine_fn_op (MINUS_EXPR, fna, fnb);
}

/* Frees affine function FN.  */

static void
affine_fn_free (affine_fn fn)
{
  fn.release ();
}

/* Determine for each subscript in the data dependence relation DDR
   the distance.  */

static void
compute_subscript_distance (struct data_dependence_relation *ddr)
{
  conflict_function *cf_a, *cf_b;
  affine_fn fn_a, fn_b, diff;

  if (DDR_ARE_DEPENDENT (ddr) == NULL_TREE)
    {
      unsigned int i;

      for (i = 0; i < DDR_NUM_SUBSCRIPTS (ddr); i++)
 	{
 	  struct subscript *subscript;

 	  subscript = DDR_SUBSCRIPT (ddr, i);
 	  cf_a = SUB_CONFLICTS_IN_A (subscript);
 	  cf_b = SUB_CONFLICTS_IN_B (subscript);

	  fn_a = common_affine_function (cf_a);
	  fn_b = common_affine_function (cf_b);
	  if (!fn_a.exists () || !fn_b.exists ())
	    {
	      SUB_DISTANCE (subscript) = chrec_dont_know;
	      return;
	    }
	  diff = affine_fn_minus (fn_a, fn_b);

 	  if (affine_function_constant_p (diff))
 	    SUB_DISTANCE (subscript) = affine_function_base (diff);
 	  else
 	    SUB_DISTANCE (subscript) = chrec_dont_know;

	  affine_fn_free (diff);
 	}
    }
}

/* Returns the conflict function for "unknown".  */

static conflict_function *
conflict_fn_not_known (void)
{
  conflict_function *fn = XCNEW (conflict_function);
  fn->n = NOT_KNOWN;

  return fn;
}

/* Returns the conflict function for "independent".  */

static conflict_function *
conflict_fn_no_dependence (void)
{
  conflict_function *fn = XCNEW (conflict_function);
  fn->n = NO_DEPENDENCE;

  return fn;
}

/* Returns true if the address of OBJ is invariant in LOOP.  */

static bool
object_address_invariant_in_loop_p (const struct loop *loop, const_tree obj)
{
  while (handled_component_p (obj))
    {
      if (TREE_CODE (obj) == ARRAY_REF)
	{
	  /* Index of the ARRAY_REF was zeroed in analyze_indices, thus we only
	     need to check the stride and the lower bound of the reference.  */
	  if (chrec_contains_symbols_defined_in_loop (TREE_OPERAND (obj, 2),
						      loop->num)
	      || chrec_contains_symbols_defined_in_loop (TREE_OPERAND (obj, 3),
							 loop->num))
	    return false;
	}
      else if (TREE_CODE (obj) == COMPONENT_REF)
	{
	  if (chrec_contains_symbols_defined_in_loop (TREE_OPERAND (obj, 2),
						      loop->num))
	    return false;
	}
      obj = TREE_OPERAND (obj, 0);
    }

  if (!INDIRECT_REF_P (obj)
      && TREE_CODE (obj) != MEM_REF)
    return true;

  return !chrec_contains_symbols_defined_in_loop (TREE_OPERAND (obj, 0),
						  loop->num);
}

/* Returns false if we can prove that data references A and B do not alias,
   true otherwise.  If LOOP_NEST is false no cross-iteration aliases are
   considered.  */

bool
dr_may_alias_p (const struct data_reference *a, const struct data_reference *b,
		bool loop_nest)
{
  tree addr_a = DR_BASE_OBJECT (a);
  tree addr_b = DR_BASE_OBJECT (b);

  /* If we are not processing a loop nest but scalar code we
     do not need to care about possible cross-iteration dependences
     and thus can process the full original reference.  Do so,
     similar to how loop invariant motion applies extra offset-based
     disambiguation.  */
  if (!loop_nest)
    {
      aff_tree off1, off2;
      widest_int size1, size2;
      get_inner_reference_aff (DR_REF (a), &off1, &size1);
      get_inner_reference_aff (DR_REF (b), &off2, &size2);
      aff_combination_scale (&off1, -1);
      aff_combination_add (&off2, &off1);
      if (aff_comb_cannot_overlap_p (&off2, size1, size2))
	return false;
    }

  if ((TREE_CODE (addr_a) == MEM_REF || TREE_CODE (addr_a) == TARGET_MEM_REF)
      && (TREE_CODE (addr_b) == MEM_REF || TREE_CODE (addr_b) == TARGET_MEM_REF)
      && MR_DEPENDENCE_CLIQUE (addr_a) == MR_DEPENDENCE_CLIQUE (addr_b)
      && MR_DEPENDENCE_BASE (addr_a) != MR_DEPENDENCE_BASE (addr_b))
    return false;

  /* If we had an evolution in a pointer-based MEM_REF BASE_OBJECT we
     do not know the size of the base-object.  So we cannot do any
     offset/overlap based analysis but have to rely on points-to
     information only.  */
  if (TREE_CODE (addr_a) == MEM_REF
      && (DR_UNCONSTRAINED_BASE (a)
	  || TREE_CODE (TREE_OPERAND (addr_a, 0)) == SSA_NAME))
    {
      /* For true dependences we can apply TBAA.  */
      if (flag_strict_aliasing
	  && DR_IS_WRITE (a) && DR_IS_READ (b)
	  && !alias_sets_conflict_p (get_alias_set (DR_REF (a)),
				     get_alias_set (DR_REF (b))))
	return false;
      if (TREE_CODE (addr_b) == MEM_REF)
	return ptr_derefs_may_alias_p (TREE_OPERAND (addr_a, 0),
				       TREE_OPERAND (addr_b, 0));
      else
	return ptr_derefs_may_alias_p (TREE_OPERAND (addr_a, 0),
				       build_fold_addr_expr (addr_b));
    }
  else if (TREE_CODE (addr_b) == MEM_REF
	   && (DR_UNCONSTRAINED_BASE (b)
	       || TREE_CODE (TREE_OPERAND (addr_b, 0)) == SSA_NAME))
    {
      /* For true dependences we can apply TBAA.  */
      if (flag_strict_aliasing
	  && DR_IS_WRITE (a) && DR_IS_READ (b)
	  && !alias_sets_conflict_p (get_alias_set (DR_REF (a)),
				     get_alias_set (DR_REF (b))))
	return false;
      if (TREE_CODE (addr_a) == MEM_REF)
	return ptr_derefs_may_alias_p (TREE_OPERAND (addr_a, 0),
				       TREE_OPERAND (addr_b, 0));
      else
	return ptr_derefs_may_alias_p (build_fold_addr_expr (addr_a),
				       TREE_OPERAND (addr_b, 0));
    }

  /* Otherwise DR_BASE_OBJECT is an access that covers the whole object
     that is being subsetted in the loop nest.  */
  if (DR_IS_WRITE (a) && DR_IS_WRITE (b))
    return refs_output_dependent_p (addr_a, addr_b);
  else if (DR_IS_READ (a) && DR_IS_WRITE (b))
    return refs_anti_dependent_p (addr_a, addr_b);
  return refs_may_alias_p (addr_a, addr_b);
}

/* REF_A and REF_B both satisfy access_fn_component_p.  Return true
   if it is meaningful to compare their associated access functions
   when checking for dependencies.  */

static bool
access_fn_components_comparable_p (tree ref_a, tree ref_b)
{
  /* Allow pairs of component refs from the following sets:

       { REALPART_EXPR, IMAGPART_EXPR }
       { COMPONENT_REF }
       { ARRAY_REF }.  */
  tree_code code_a = TREE_CODE (ref_a);
  tree_code code_b = TREE_CODE (ref_b);
  if (code_a == IMAGPART_EXPR)
    code_a = REALPART_EXPR;
  if (code_b == IMAGPART_EXPR)
    code_b = REALPART_EXPR;
  if (code_a != code_b)
    return false;

  if (TREE_CODE (ref_a) == COMPONENT_REF)
    /* ??? We cannot simply use the type of operand #0 of the refs here as
       the Fortran compiler smuggles type punning into COMPONENT_REFs.
       Use the DECL_CONTEXT of the FIELD_DECLs instead.  */
    return (DECL_CONTEXT (TREE_OPERAND (ref_a, 1))
	    == DECL_CONTEXT (TREE_OPERAND (ref_b, 1)));

  return types_compatible_p (TREE_TYPE (TREE_OPERAND (ref_a, 0)),
			     TREE_TYPE (TREE_OPERAND (ref_b, 0)));
}

/* Initialize a data dependence relation between data accesses A and
   B.  NB_LOOPS is the number of loops surrounding the references: the
   size of the classic distance/direction vectors.  */

struct data_dependence_relation *
initialize_data_dependence_relation (struct data_reference *a,
				     struct data_reference *b,
 				     vec<loop_p> loop_nest)
{
  struct data_dependence_relation *res;
  unsigned int i;

  res = XCNEW (struct data_dependence_relation);
  DDR_A (res) = a;
  DDR_B (res) = b;
  DDR_LOOP_NEST (res).create (0);
  DDR_SUBSCRIPTS (res).create (0);
  DDR_DIR_VECTS (res).create (0);
  DDR_DIST_VECTS (res).create (0);

  if (a == NULL || b == NULL)
    {
      DDR_ARE_DEPENDENT (res) = chrec_dont_know;
      return res;
    }

  /* If the data references do not alias, then they are independent.  */
  if (!dr_may_alias_p (a, b, loop_nest.exists ()))
    {
      DDR_ARE_DEPENDENT (res) = chrec_known;
      return res;
    }

  unsigned int num_dimensions_a = DR_NUM_DIMENSIONS (a);
  unsigned int num_dimensions_b = DR_NUM_DIMENSIONS (b);
  if (num_dimensions_a == 0 || num_dimensions_b == 0)
    {
      DDR_ARE_DEPENDENT (res) = chrec_dont_know;
      return res;
    }

  /* For unconstrained bases, the root (highest-indexed) subscript
     describes a variation in the base of the original DR_REF rather
     than a component access.  We have no type that accurately describes
     the new DR_BASE_OBJECT (whose TREE_TYPE describes the type *after*
     applying this subscript) so limit the search to the last real
     component access.

     E.g. for:

	void
	f (int a[][8], int b[][8])
	{
	  for (int i = 0; i < 8; ++i)
	    a[i * 2][0] = b[i][0];
	}

     the a and b accesses have a single ARRAY_REF component reference [0]
     but have two subscripts.  */
  if (DR_UNCONSTRAINED_BASE (a))
    num_dimensions_a -= 1;
  if (DR_UNCONSTRAINED_BASE (b))
    num_dimensions_b -= 1;

  /* These structures describe sequences of component references in
     DR_REF (A) and DR_REF (B).  Each component reference is tied to a
     specific access function.  */
  struct {
    /* The sequence starts at DR_ACCESS_FN (A, START_A) of A and
       DR_ACCESS_FN (B, START_B) of B (inclusive) and extends to higher
       indices.  In C notation, these are the indices of the rightmost
       component references; e.g. for a sequence .b.c.d, the start
       index is for .d.  */
    unsigned int start_a;
    unsigned int start_b;

    /* The sequence contains LENGTH consecutive access functions from
       each DR.  */
    unsigned int length;

    /* The enclosing objects for the A and B sequences respectively,
       i.e. the objects to which DR_ACCESS_FN (A, START_A + LENGTH - 1)
       and DR_ACCESS_FN (B, START_B + LENGTH - 1) are applied.  */
    tree object_a;
    tree object_b;
  } full_seq = {}, struct_seq = {};

  /* Before each iteration of the loop:

     - REF_A is what you get after applying DR_ACCESS_FN (A, INDEX_A) and
     - REF_B is what you get after applying DR_ACCESS_FN (B, INDEX_B).  */
  unsigned int index_a = 0;
  unsigned int index_b = 0;
  tree ref_a = DR_REF (a);
  tree ref_b = DR_REF (b);

  /* Now walk the component references from the final DR_REFs back up to
     the enclosing base objects.  Each component reference corresponds
     to one access function in the DR, with access function 0 being for
     the final DR_REF and the highest-indexed access function being the
     one that is applied to the base of the DR.

     Look for a sequence of component references whose access functions
     are comparable (see access_fn_components_comparable_p).  If more
     than one such sequence exists, pick the one nearest the base
     (which is the leftmost sequence in C notation).  Store this sequence
     in FULL_SEQ.

     For example, if we have:

	struct foo { struct bar s; ... } (*a)[10], (*b)[10];

	A: a[0][i].s.c.d
	B: __real b[0][i].s.e[i].f

     (where d is the same type as the real component of f) then the access
     functions would be:

			 0   1   2   3
	A:              .d  .c  .s [i]

		 0   1   2   3   4   5
	B:  __real  .f [i]  .e  .s [i]

     The A0/B2 column isn't comparable, since .d is a COMPONENT_REF
     and [i] is an ARRAY_REF.  However, the A1/B3 column contains two
     COMPONENT_REF accesses for struct bar, so is comparable.  Likewise
     the A2/B4 column contains two COMPONENT_REF accesses for struct foo,
     so is comparable.  The A3/B5 column contains two ARRAY_REFs that
     index foo[10] arrays, so is again comparable.  The sequence is
     therefore:

        A: [1, 3]  (i.e. [i].s.c)
        B: [3, 5]  (i.e. [i].s.e)

     Also look for sequences of component references whose access
     functions are comparable and whose enclosing objects have the same
     RECORD_TYPE.  Store this sequence in STRUCT_SEQ.  In the above
     example, STRUCT_SEQ would be:

        A: [1, 2]  (i.e. s.c)
        B: [3, 4]  (i.e. s.e)  */
  while (index_a < num_dimensions_a && index_b < num_dimensions_b)
    {
      /* REF_A and REF_B must be one of the component access types
	 allowed by dr_analyze_indices.  */
      gcc_checking_assert (access_fn_component_p (ref_a));
      gcc_checking_assert (access_fn_component_p (ref_b));

      /* Get the immediately-enclosing objects for REF_A and REF_B,
	 i.e. the references *before* applying DR_ACCESS_FN (A, INDEX_A)
	 and DR_ACCESS_FN (B, INDEX_B).  */
      tree object_a = TREE_OPERAND (ref_a, 0);
      tree object_b = TREE_OPERAND (ref_b, 0);

      tree type_a = TREE_TYPE (object_a);
      tree type_b = TREE_TYPE (object_b);
      if (access_fn_components_comparable_p (ref_a, ref_b))
	{
	  /* This pair of component accesses is comparable for dependence
	     analysis, so we can include DR_ACCESS_FN (A, INDEX_A) and
	     DR_ACCESS_FN (B, INDEX_B) in the sequence.  */
	  if (full_seq.start_a + full_seq.length != index_a
	      || full_seq.start_b + full_seq.length != index_b)
	    {
	      /* The accesses don't extend the current sequence,
		 so start a new one here.  */
	      full_seq.start_a = index_a;
	      full_seq.start_b = index_b;
	      full_seq.length = 0;
	    }

	  /* Add this pair of references to the sequence.  */
	  full_seq.length += 1;
	  full_seq.object_a = object_a;
	  full_seq.object_b = object_b;

	  /* If the enclosing objects are structures (and thus have the
	     same RECORD_TYPE), record the new sequence in STRUCT_SEQ.  */
	  if (TREE_CODE (type_a) == RECORD_TYPE)
	    struct_seq = full_seq;

	  /* Move to the next containing reference for both A and B.  */
	  ref_a = object_a;
	  ref_b = object_b;
	  index_a += 1;
	  index_b += 1;
	  continue;
	}

      /* Try to approach equal type sizes.  */
      if (!COMPLETE_TYPE_P (type_a)
	  || !COMPLETE_TYPE_P (type_b)
	  || !tree_fits_uhwi_p (TYPE_SIZE_UNIT (type_a))
	  || !tree_fits_uhwi_p (TYPE_SIZE_UNIT (type_b)))
	break;

      unsigned HOST_WIDE_INT size_a = tree_to_uhwi (TYPE_SIZE_UNIT (type_a));
      unsigned HOST_WIDE_INT size_b = tree_to_uhwi (TYPE_SIZE_UNIT (type_b));
      if (size_a <= size_b)
	{
	  index_a += 1;
	  ref_a = object_a;
	}
      if (size_b <= size_a)
	{
	  index_b += 1;
	  ref_b = object_b;
	}
    }

  /* See whether FULL_SEQ ends at the base and whether the two bases
     are equal.  We do not care about TBAA or alignment info so we can
     use OEP_ADDRESS_OF to avoid false negatives.  */
  tree base_a = DR_BASE_OBJECT (a);
  tree base_b = DR_BASE_OBJECT (b);
  bool same_base_p = (full_seq.start_a + full_seq.length == num_dimensions_a
		      && full_seq.start_b + full_seq.length == num_dimensions_b
		      && DR_UNCONSTRAINED_BASE (a) == DR_UNCONSTRAINED_BASE (b)
		      && operand_equal_p (base_a, base_b, OEP_ADDRESS_OF)
		      && types_compatible_p (TREE_TYPE (base_a),
					     TREE_TYPE (base_b))
		      && (!loop_nest.exists ()
			  || (object_address_invariant_in_loop_p
			      (loop_nest[0], base_a))));

  /* If the bases are the same, we can include the base variation too.
     E.g. the b accesses in:

       for (int i = 0; i < n; ++i)
         b[i + 4][0] = b[i][0];

     have a definite dependence distance of 4, while for:

       for (int i = 0; i < n; ++i)
         a[i + 4][0] = b[i][0];

     the dependence distance depends on the gap between a and b.

     If the bases are different then we can only rely on the sequence
     rooted at a structure access, since arrays are allowed to overlap
     arbitrarily and change shape arbitrarily.  E.g. we treat this as
     valid code:

       int a[256];
       ...
       ((int (*)[4][3]) &a[1])[i][0] += ((int (*)[4][3]) &a[2])[i][0];

     where two lvalues with the same int[4][3] type overlap, and where
     both lvalues are distinct from the object's declared type.  */
  if (same_base_p)
    {
      if (DR_UNCONSTRAINED_BASE (a))
	full_seq.length += 1;
    }
  else
    full_seq = struct_seq;

  /* Punt if we didn't find a suitable sequence.  */
  if (full_seq.length == 0)
    {
      DDR_ARE_DEPENDENT (res) = chrec_dont_know;
      return res;
    }

  if (!same_base_p)
    {
      /* Partial overlap is possible for different bases when strict aliasing
	 is not in effect.  It's also possible if either base involves a union
	 access; e.g. for:

	   struct s1 { int a[2]; };
	   struct s2 { struct s1 b; int c; };
	   struct s3 { int d; struct s1 e; };
	   union u { struct s2 f; struct s3 g; } *p, *q;

	 the s1 at "p->f.b" (base "p->f") partially overlaps the s1 at
	 "p->g.e" (base "p->g") and might partially overlap the s1 at
	 "q->g.e" (base "q->g").  */
      if (!flag_strict_aliasing
	  || ref_contains_union_access_p (full_seq.object_a)
	  || ref_contains_union_access_p (full_seq.object_b))
	{
	  DDR_ARE_DEPENDENT (res) = chrec_dont_know;
	  return res;
	}

      DDR_COULD_BE_INDEPENDENT_P (res) = true;
      if (!loop_nest.exists ()
	  || (object_address_invariant_in_loop_p (loop_nest[0],
						  full_seq.object_a)
	      && object_address_invariant_in_loop_p (loop_nest[0],
						     full_seq.object_b)))
	{
	  DDR_OBJECT_A (res) = full_seq.object_a;
	  DDR_OBJECT_B (res) = full_seq.object_b;
	}
    }

  DDR_AFFINE_P (res) = true;
  DDR_ARE_DEPENDENT (res) = NULL_TREE;
  DDR_SUBSCRIPTS (res).create (full_seq.length);
  DDR_LOOP_NEST (res) = loop_nest;
  DDR_INNER_LOOP (res) = 0;
  DDR_SELF_REFERENCE (res) = false;

  for (i = 0; i < full_seq.length; ++i)
    {
      struct subscript *subscript;

      subscript = XNEW (struct subscript);
      SUB_ACCESS_FN (subscript, 0) = DR_ACCESS_FN (a, full_seq.start_a + i);
      SUB_ACCESS_FN (subscript, 1) = DR_ACCESS_FN (b, full_seq.start_b + i);
      SUB_CONFLICTS_IN_A (subscript) = conflict_fn_not_known ();
      SUB_CONFLICTS_IN_B (subscript) = conflict_fn_not_known ();
      SUB_LAST_CONFLICT (subscript) = chrec_dont_know;
      SUB_DISTANCE (subscript) = chrec_dont_know;
      DDR_SUBSCRIPTS (res).safe_push (subscript);
    }

  return res;
}

/* Frees memory used by the conflict function F.  */

static void
free_conflict_function (conflict_function *f)
{
  unsigned i;

  if (CF_NONTRIVIAL_P (f))
    {
      for (i = 0; i < f->n; i++)
	affine_fn_free (f->fns[i]);
    }
  free (f);
}

/* Frees memory used by SUBSCRIPTS.  */

static void
free_subscripts (vec<subscript_p> subscripts)
{
  unsigned i;
  subscript_p s;

  FOR_EACH_VEC_ELT (subscripts, i, s)
    {
      free_conflict_function (s->conflicting_iterations_in_a);
      free_conflict_function (s->conflicting_iterations_in_b);
      free (s);
    }
  subscripts.release ();
}

/* Set DDR_ARE_DEPENDENT to CHREC and finalize the subscript overlap
   description.  */

static inline void
finalize_ddr_dependent (struct data_dependence_relation *ddr,
			tree chrec)
{
  DDR_ARE_DEPENDENT (ddr) = chrec;
  free_subscripts (DDR_SUBSCRIPTS (ddr));
  DDR_SUBSCRIPTS (ddr).create (0);
}

/* The dependence relation DDR cannot be represented by a distance
   vector.  */

static inline void
non_affine_dependence_relation (struct data_dependence_relation *ddr)
{
  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "(Dependence relation cannot be represented by distance vector.) \n");

  DDR_AFFINE_P (ddr) = false;
}



/* This section contains the classic Banerjee tests.  */

/* Returns true iff CHREC_A and CHREC_B are not dependent on any index
   variables, i.e., if the ZIV (Zero Index Variable) test is true.  */

static inline bool
ziv_subscript_p (const_tree chrec_a, const_tree chrec_b)
{
  return (evolution_function_is_constant_p (chrec_a)
	  && evolution_function_is_constant_p (chrec_b));
}

/* Returns true iff CHREC_A and CHREC_B are dependent on an index
   variable, i.e., if the SIV (Single Index Variable) test is true.  */

static bool
siv_subscript_p (const_tree chrec_a, const_tree chrec_b)
{
  if ((evolution_function_is_constant_p (chrec_a)
       && evolution_function_is_univariate_p (chrec_b))
      || (evolution_function_is_constant_p (chrec_b)
	  && evolution_function_is_univariate_p (chrec_a)))
    return true;

  if (evolution_function_is_univariate_p (chrec_a)
      && evolution_function_is_univariate_p (chrec_b))
    {
      switch (TREE_CODE (chrec_a))
	{
	case POLYNOMIAL_CHREC:
	  switch (TREE_CODE (chrec_b))
	    {
	    case POLYNOMIAL_CHREC:
	      if (CHREC_VARIABLE (chrec_a) != CHREC_VARIABLE (chrec_b))
		return false;
	      /* FALLTHRU */

	    default:
	      return true;
	    }

	default:
	  return true;
	}
    }

  return false;
}

/* Creates a conflict function with N dimensions.  The affine functions
   in each dimension follow.  */

static conflict_function *
conflict_fn (unsigned n, ...)
{
  unsigned i;
  conflict_function *ret = XCNEW (conflict_function);
  va_list ap;

  gcc_assert (0 < n && n <= MAX_DIM);
  va_start (ap, n);

  ret->n = n;
  for (i = 0; i < n; i++)
    ret->fns[i] = va_arg (ap, affine_fn);
  va_end (ap);

  return ret;
}

/* Returns constant affine function with value CST.  */

static affine_fn
affine_fn_cst (tree cst)
{
  affine_fn fn;
  fn.create (1);
  fn.quick_push (cst);
  return fn;
}

/* Returns affine function with single variable, CST + COEF * x_DIM.  */

static affine_fn
affine_fn_univar (tree cst, unsigned dim, tree coef)
{
  affine_fn fn;
  fn.create (dim + 1);
  unsigned i;

  gcc_assert (dim > 0);
  fn.quick_push (cst);
  for (i = 1; i < dim; i++)
    fn.quick_push (integer_zero_node);
  fn.quick_push (coef);
  return fn;
}

/* Analyze a ZIV (Zero Index Variable) subscript.  *OVERLAPS_A and
   *OVERLAPS_B are initialized to the functions that describe the
   relation between the elements accessed twice by CHREC_A and
   CHREC_B.  For k >= 0, the following property is verified:

   CHREC_A (*OVERLAPS_A (k)) = CHREC_B (*OVERLAPS_B (k)).  */

static void
analyze_ziv_subscript (tree chrec_a,
		       tree chrec_b,
		       conflict_function **overlaps_a,
		       conflict_function **overlaps_b,
		       tree *last_conflicts)
{
  tree type, difference;
  dependence_stats.num_ziv++;

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "(analyze_ziv_subscript \n");

  type = signed_type_for_types (TREE_TYPE (chrec_a), TREE_TYPE (chrec_b));
  chrec_a = chrec_convert (type, chrec_a, NULL);
  chrec_b = chrec_convert (type, chrec_b, NULL);
  difference = chrec_fold_minus (type, chrec_a, chrec_b);

  switch (TREE_CODE (difference))
    {
    case INTEGER_CST:
      if (integer_zerop (difference))
	{
	  /* The difference is equal to zero: the accessed index
	     overlaps for each iteration in the loop.  */
	  *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
	  *overlaps_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
	  *last_conflicts = chrec_dont_know;
	  dependence_stats.num_ziv_dependent++;
	}
      else
	{
	  /* The accesses do not overlap.  */
	  *overlaps_a = conflict_fn_no_dependence ();
	  *overlaps_b = conflict_fn_no_dependence ();
	  *last_conflicts = integer_zero_node;
	  dependence_stats.num_ziv_independent++;
	}
      break;

    default:
      /* We're not sure whether the indexes overlap.  For the moment,
	 conservatively answer "don't know".  */
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "ziv test failed: difference is non-integer.\n");

      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      dependence_stats.num_ziv_unimplemented++;
      break;
    }

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, ")\n");
}

/* Similar to max_stmt_executions_int, but returns the bound as a tree,
   and only if it fits to the int type.  If this is not the case, or the
   bound  on the number of iterations of LOOP could not be derived, returns
   chrec_dont_know.  */

static tree
max_stmt_executions_tree (struct loop *loop)
{
  widest_int nit;

  if (!max_stmt_executions (loop, &nit))
    return chrec_dont_know;

  if (!wi::fits_to_tree_p (nit, unsigned_type_node))
    return chrec_dont_know;

  return wide_int_to_tree (unsigned_type_node, nit);
}

/* Determine whether the CHREC is always positive/negative.  If the expression
   cannot be statically analyzed, return false, otherwise set the answer into
   VALUE.  */

static bool
chrec_is_positive (tree chrec, bool *value)
{
  bool value0, value1, value2;
  tree end_value, nb_iter;

  switch (TREE_CODE (chrec))
    {
    case POLYNOMIAL_CHREC:
      if (!chrec_is_positive (CHREC_LEFT (chrec), &value0)
	  || !chrec_is_positive (CHREC_RIGHT (chrec), &value1))
	return false;

      /* FIXME -- overflows.  */
      if (value0 == value1)
	{
	  *value = value0;
	  return true;
	}

      /* Otherwise the chrec is under the form: "{-197, +, 2}_1",
	 and the proof consists in showing that the sign never
	 changes during the execution of the loop, from 0 to
	 loop->nb_iterations.  */
      if (!evolution_function_is_affine_p (chrec))
	return false;

      nb_iter = number_of_latch_executions (get_chrec_loop (chrec));
      if (chrec_contains_undetermined (nb_iter))
	return false;

#if 0
      /* TODO -- If the test is after the exit, we may decrease the number of
	 iterations by one.  */
      if (after_exit)
	nb_iter = chrec_fold_minus (type, nb_iter, build_int_cst (type, 1));
#endif

      end_value = chrec_apply (CHREC_VARIABLE (chrec), chrec, nb_iter);

      if (!chrec_is_positive (end_value, &value2))
	return false;

      *value = value0;
      return value0 == value1;

    case INTEGER_CST:
      switch (tree_int_cst_sgn (chrec))
	{
	case -1:
	  *value = false;
	  break;
	case 1:
	  *value = true;
	  break;
	default:
	  return false;
	}
      return true;

    default:
      return false;
    }
}


/* Analyze a SIV (Single Index Variable) subscript where CHREC_A is a
   constant, and CHREC_B is an affine function.  *OVERLAPS_A and
   *OVERLAPS_B are initialized to the functions that describe the
   relation between the elements accessed twice by CHREC_A and
   CHREC_B.  For k >= 0, the following property is verified:

   CHREC_A (*OVERLAPS_A (k)) = CHREC_B (*OVERLAPS_B (k)).  */

static void
analyze_siv_subscript_cst_affine (tree chrec_a,
				  tree chrec_b,
				  conflict_function **overlaps_a,
				  conflict_function **overlaps_b,
				  tree *last_conflicts)
{
  bool value0, value1, value2;
  tree type, difference, tmp;

  type = signed_type_for_types (TREE_TYPE (chrec_a), TREE_TYPE (chrec_b));
  chrec_a = chrec_convert (type, chrec_a, NULL);
  chrec_b = chrec_convert (type, chrec_b, NULL);
  difference = chrec_fold_minus (type, initial_condition (chrec_b), chrec_a);

  /* Special case overlap in the first iteration.  */
  if (integer_zerop (difference))
    {
      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *overlaps_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *last_conflicts = integer_one_node;
      return;
    }

  if (!chrec_is_positive (initial_condition (difference), &value0))
    {
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "siv test failed: chrec is not positive.\n");

      dependence_stats.num_siv_unimplemented++;
      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      return;
    }
  else
    {
      if (value0 == false)
	{
	  if (!chrec_is_positive (CHREC_RIGHT (chrec_b), &value1))
	    {
	      if (dump_file && (dump_flags & TDF_DETAILS))
		fprintf (dump_file, "siv test failed: chrec not positive.\n");

	      *overlaps_a = conflict_fn_not_known ();
	      *overlaps_b = conflict_fn_not_known ();
	      *last_conflicts = chrec_dont_know;
	      dependence_stats.num_siv_unimplemented++;
	      return;
	    }
	  else
	    {
	      if (value1 == true)
		{
		  /* Example:
		     chrec_a = 12
		     chrec_b = {10, +, 1}
		  */

		  if (tree_fold_divides_p (CHREC_RIGHT (chrec_b), difference))
		    {
		      HOST_WIDE_INT numiter;
		      struct loop *loop = get_chrec_loop (chrec_b);

		      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
		      tmp = fold_build2 (EXACT_DIV_EXPR, type,
					 fold_build1 (ABS_EXPR, type, difference),
					 CHREC_RIGHT (chrec_b));
		      *overlaps_b = conflict_fn (1, affine_fn_cst (tmp));
		      *last_conflicts = integer_one_node;


		      /* Perform weak-zero siv test to see if overlap is
			 outside the loop bounds.  */
		      numiter = max_stmt_executions_int (loop);

		      if (numiter >= 0
			  && compare_tree_int (tmp, numiter) > 0)
			{
			  free_conflict_function (*overlaps_a);
			  free_conflict_function (*overlaps_b);
			  *overlaps_a = conflict_fn_no_dependence ();
			  *overlaps_b = conflict_fn_no_dependence ();
			  *last_conflicts = integer_zero_node;
			  dependence_stats.num_siv_independent++;
			  return;
			}
		      dependence_stats.num_siv_dependent++;
		      return;
		    }

		  /* When the step does not divide the difference, there are
		     no overlaps.  */
		  else
		    {
		      *overlaps_a = conflict_fn_no_dependence ();
		      *overlaps_b = conflict_fn_no_dependence ();
		      *last_conflicts = integer_zero_node;
		      dependence_stats.num_siv_independent++;
		      return;
		    }
		}

	      else
		{
		  /* Example:
		     chrec_a = 12
		     chrec_b = {10, +, -1}

		     In this case, chrec_a will not overlap with chrec_b.  */
		  *overlaps_a = conflict_fn_no_dependence ();
		  *overlaps_b = conflict_fn_no_dependence ();
		  *last_conflicts = integer_zero_node;
		  dependence_stats.num_siv_independent++;
		  return;
		}
	    }
	}
      else
	{
	  if (!chrec_is_positive (CHREC_RIGHT (chrec_b), &value2))
	    {
	      if (dump_file && (dump_flags & TDF_DETAILS))
		fprintf (dump_file, "siv test failed: chrec not positive.\n");

	      *overlaps_a = conflict_fn_not_known ();
	      *overlaps_b = conflict_fn_not_known ();
	      *last_conflicts = chrec_dont_know;
	      dependence_stats.num_siv_unimplemented++;
	      return;
	    }
	  else
	    {
	      if (value2 == false)
		{
		  /* Example:
		     chrec_a = 3
		     chrec_b = {10, +, -1}
		  */
		  if (tree_fold_divides_p (CHREC_RIGHT (chrec_b), difference))
		    {
		      HOST_WIDE_INT numiter;
		      struct loop *loop = get_chrec_loop (chrec_b);

		      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
		      tmp = fold_build2 (EXACT_DIV_EXPR, type, difference,
					 CHREC_RIGHT (chrec_b));
		      *overlaps_b = conflict_fn (1, affine_fn_cst (tmp));
		      *last_conflicts = integer_one_node;

		      /* Perform weak-zero siv test to see if overlap is
			 outside the loop bounds.  */
		      numiter = max_stmt_executions_int (loop);

		      if (numiter >= 0
			  && compare_tree_int (tmp, numiter) > 0)
			{
			  free_conflict_function (*overlaps_a);
			  free_conflict_function (*overlaps_b);
			  *overlaps_a = conflict_fn_no_dependence ();
			  *overlaps_b = conflict_fn_no_dependence ();
			  *last_conflicts = integer_zero_node;
			  dependence_stats.num_siv_independent++;
			  return;
			}
		      dependence_stats.num_siv_dependent++;
		      return;
		    }

		  /* When the step does not divide the difference, there
		     are no overlaps.  */
		  else
		    {
		      *overlaps_a = conflict_fn_no_dependence ();
		      *overlaps_b = conflict_fn_no_dependence ();
		      *last_conflicts = integer_zero_node;
		      dependence_stats.num_siv_independent++;
		      return;
		    }
		}
	      else
		{
		  /* Example:
		     chrec_a = 3
		     chrec_b = {4, +, 1}

		     In this case, chrec_a will not overlap with chrec_b.  */
		  *overlaps_a = conflict_fn_no_dependence ();
		  *overlaps_b = conflict_fn_no_dependence ();
		  *last_conflicts = integer_zero_node;
		  dependence_stats.num_siv_independent++;
		  return;
		}
	    }
	}
    }
}

/* Helper recursive function for initializing the matrix A.  Returns
   the initial value of CHREC.  */

static tree
initialize_matrix_A (lambda_matrix A, tree chrec, unsigned index, int mult)
{
  gcc_assert (chrec);

  switch (TREE_CODE (chrec))
    {
    case POLYNOMIAL_CHREC:
      A[index][0] = mult * int_cst_value (CHREC_RIGHT (chrec));
      return initialize_matrix_A (A, CHREC_LEFT (chrec), index + 1, mult);

    case PLUS_EXPR:
    case MULT_EXPR:
    case MINUS_EXPR:
      {
	tree op0 = initialize_matrix_A (A, TREE_OPERAND (chrec, 0), index, mult);
	tree op1 = initialize_matrix_A (A, TREE_OPERAND (chrec, 1), index, mult);

	return chrec_fold_op (TREE_CODE (chrec), chrec_type (chrec), op0, op1);
      }

    CASE_CONVERT:
      {
	tree op = initialize_matrix_A (A, TREE_OPERAND (chrec, 0), index, mult);
	return chrec_convert (chrec_type (chrec), op, NULL);
      }

    case BIT_NOT_EXPR:
      {
	/* Handle ~X as -1 - X.  */
	tree op = initialize_matrix_A (A, TREE_OPERAND (chrec, 0), index, mult);
	return chrec_fold_op (MINUS_EXPR, chrec_type (chrec),
			      build_int_cst (TREE_TYPE (chrec), -1), op);
      }

    case INTEGER_CST:
      return chrec;

    default:
      gcc_unreachable ();
      return NULL_TREE;
    }
}

#define FLOOR_DIV(x,y) ((x) / (y))

/* Solves the special case of the Diophantine equation:
   | {0, +, STEP_A}_x (OVERLAPS_A) = {0, +, STEP_B}_y (OVERLAPS_B)

   Computes the descriptions OVERLAPS_A and OVERLAPS_B.  NITER is the
   number of iterations that loops X and Y run.  The overlaps will be
   constructed as evolutions in dimension DIM.  */

static void
compute_overlap_steps_for_affine_univar (HOST_WIDE_INT niter,
					 HOST_WIDE_INT step_a,
					 HOST_WIDE_INT step_b,
					 affine_fn *overlaps_a,
					 affine_fn *overlaps_b,
					 tree *last_conflicts, int dim)
{
  if (((step_a > 0 && step_b > 0)
       || (step_a < 0 && step_b < 0)))
    {
      HOST_WIDE_INT step_overlaps_a, step_overlaps_b;
      HOST_WIDE_INT gcd_steps_a_b, last_conflict, tau2;

      gcd_steps_a_b = gcd (step_a, step_b);
      step_overlaps_a = step_b / gcd_steps_a_b;
      step_overlaps_b = step_a / gcd_steps_a_b;

      if (niter > 0)
	{
	  tau2 = FLOOR_DIV (niter, step_overlaps_a);
	  tau2 = MIN (tau2, FLOOR_DIV (niter, step_overlaps_b));
	  last_conflict = tau2;
	  *last_conflicts = build_int_cst (NULL_TREE, last_conflict);
	}
      else
	*last_conflicts = chrec_dont_know;

      *overlaps_a = affine_fn_univar (integer_zero_node, dim,
				      build_int_cst (NULL_TREE,
						     step_overlaps_a));
      *overlaps_b = affine_fn_univar (integer_zero_node, dim,
				      build_int_cst (NULL_TREE,
						     step_overlaps_b));
    }

  else
    {
      *overlaps_a = affine_fn_cst (integer_zero_node);
      *overlaps_b = affine_fn_cst (integer_zero_node);
      *last_conflicts = integer_zero_node;
    }
}

/* Solves the special case of a Diophantine equation where CHREC_A is
   an affine bivariate function, and CHREC_B is an affine univariate
   function.  For example,

   | {{0, +, 1}_x, +, 1335}_y = {0, +, 1336}_z

   has the following overlapping functions:

   | x (t, u, v) = {{0, +, 1336}_t, +, 1}_v
   | y (t, u, v) = {{0, +, 1336}_u, +, 1}_v
   | z (t, u, v) = {{{0, +, 1}_t, +, 1335}_u, +, 1}_v

   FORNOW: This is a specialized implementation for a case occurring in
   a common benchmark.  Implement the general algorithm.  */

static void
compute_overlap_steps_for_affine_1_2 (tree chrec_a, tree chrec_b,
				      conflict_function **overlaps_a,
				      conflict_function **overlaps_b,
				      tree *last_conflicts)
{
  bool xz_p, yz_p, xyz_p;
  HOST_WIDE_INT step_x, step_y, step_z;
  HOST_WIDE_INT niter_x, niter_y, niter_z, niter;
  affine_fn overlaps_a_xz, overlaps_b_xz;
  affine_fn overlaps_a_yz, overlaps_b_yz;
  affine_fn overlaps_a_xyz, overlaps_b_xyz;
  affine_fn ova1, ova2, ovb;
  tree last_conflicts_xz, last_conflicts_yz, last_conflicts_xyz;

  step_x = int_cst_value (CHREC_RIGHT (CHREC_LEFT (chrec_a)));
  step_y = int_cst_value (CHREC_RIGHT (chrec_a));
  step_z = int_cst_value (CHREC_RIGHT (chrec_b));

  niter_x = max_stmt_executions_int (get_chrec_loop (CHREC_LEFT (chrec_a)));
  niter_y = max_stmt_executions_int (get_chrec_loop (chrec_a));
  niter_z = max_stmt_executions_int (get_chrec_loop (chrec_b));

  if (niter_x < 0 || niter_y < 0 || niter_z < 0)
    {
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "overlap steps test failed: no iteration counts.\n");

      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      return;
    }

  niter = MIN (niter_x, niter_z);
  compute_overlap_steps_for_affine_univar (niter, step_x, step_z,
					   &overlaps_a_xz,
					   &overlaps_b_xz,
					   &last_conflicts_xz, 1);
  niter = MIN (niter_y, niter_z);
  compute_overlap_steps_for_affine_univar (niter, step_y, step_z,
					   &overlaps_a_yz,
					   &overlaps_b_yz,
					   &last_conflicts_yz, 2);
  niter = MIN (niter_x, niter_z);
  niter = MIN (niter_y, niter);
  compute_overlap_steps_for_affine_univar (niter, step_x + step_y, step_z,
					   &overlaps_a_xyz,
					   &overlaps_b_xyz,
					   &last_conflicts_xyz, 3);

  xz_p = !integer_zerop (last_conflicts_xz);
  yz_p = !integer_zerop (last_conflicts_yz);
  xyz_p = !integer_zerop (last_conflicts_xyz);

  if (xz_p || yz_p || xyz_p)
    {
      ova1 = affine_fn_cst (integer_zero_node);
      ova2 = affine_fn_cst (integer_zero_node);
      ovb = affine_fn_cst (integer_zero_node);
      if (xz_p)
	{
	  affine_fn t0 = ova1;
	  affine_fn t2 = ovb;

	  ova1 = affine_fn_plus (ova1, overlaps_a_xz);
	  ovb = affine_fn_plus (ovb, overlaps_b_xz);
	  affine_fn_free (t0);
	  affine_fn_free (t2);
	  *last_conflicts = last_conflicts_xz;
	}
      if (yz_p)
	{
	  affine_fn t0 = ova2;
	  affine_fn t2 = ovb;

	  ova2 = affine_fn_plus (ova2, overlaps_a_yz);
	  ovb = affine_fn_plus (ovb, overlaps_b_yz);
	  affine_fn_free (t0);
	  affine_fn_free (t2);
	  *last_conflicts = last_conflicts_yz;
	}
      if (xyz_p)
	{
	  affine_fn t0 = ova1;
	  affine_fn t2 = ova2;
	  affine_fn t4 = ovb;

	  ova1 = affine_fn_plus (ova1, overlaps_a_xyz);
	  ova2 = affine_fn_plus (ova2, overlaps_a_xyz);
	  ovb = affine_fn_plus (ovb, overlaps_b_xyz);
	  affine_fn_free (t0);
	  affine_fn_free (t2);
	  affine_fn_free (t4);
	  *last_conflicts = last_conflicts_xyz;
	}
      *overlaps_a = conflict_fn (2, ova1, ova2);
      *overlaps_b = conflict_fn (1, ovb);
    }
  else
    {
      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *overlaps_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *last_conflicts = integer_zero_node;
    }

  affine_fn_free (overlaps_a_xz);
  affine_fn_free (overlaps_b_xz);
  affine_fn_free (overlaps_a_yz);
  affine_fn_free (overlaps_b_yz);
  affine_fn_free (overlaps_a_xyz);
  affine_fn_free (overlaps_b_xyz);
}

/* Copy the elements of vector VEC1 with length SIZE to VEC2.  */

static void
lambda_vector_copy (lambda_vector vec1, lambda_vector vec2,
		    int size)
{
  memcpy (vec2, vec1, size * sizeof (*vec1));
}

/* Copy the elements of M x N matrix MAT1 to MAT2.  */

static void
lambda_matrix_copy (lambda_matrix mat1, lambda_matrix mat2,
		    int m, int n)
{
  int i;

  for (i = 0; i < m; i++)
    lambda_vector_copy (mat1[i], mat2[i], n);
}

/* Store the N x N identity matrix in MAT.  */

static void
lambda_matrix_id (lambda_matrix mat, int size)
{
  int i, j;

  for (i = 0; i < size; i++)
    for (j = 0; j < size; j++)
      mat[i][j] = (i == j) ? 1 : 0;
}

/* Return the first nonzero element of vector VEC1 between START and N.
   We must have START <= N.   Returns N if VEC1 is the zero vector.  */

static int
lambda_vector_first_nz (lambda_vector vec1, int n, int start)
{
  int j = start;
  while (j < n && vec1[j] == 0)
    j++;
  return j;
}

/* Add a multiple of row R1 of matrix MAT with N columns to row R2:
   R2 = R2 + CONST1 * R1.  */

static void
lambda_matrix_row_add (lambda_matrix mat, int n, int r1, int r2, int const1)
{
  int i;

  if (const1 == 0)
    return;

  for (i = 0; i < n; i++)
    mat[r2][i] += const1 * mat[r1][i];
}

/* Multiply vector VEC1 of length SIZE by a constant CONST1,
   and store the result in VEC2.  */

static void
lambda_vector_mult_const (lambda_vector vec1, lambda_vector vec2,
			  int size, int const1)
{
  int i;

  if (const1 == 0)
    lambda_vector_clear (vec2, size);
  else
    for (i = 0; i < size; i++)
      vec2[i] = const1 * vec1[i];
}

/* Negate vector VEC1 with length SIZE and store it in VEC2.  */

static void
lambda_vector_negate (lambda_vector vec1, lambda_vector vec2,
		      int size)
{
  lambda_vector_mult_const (vec1, vec2, size, -1);
}

/* Negate row R1 of matrix MAT which has N columns.  */

static void
lambda_matrix_row_negate (lambda_matrix mat, int n, int r1)
{
  lambda_vector_negate (mat[r1], mat[r1], n);
}

/* Return true if two vectors are equal.  */

static bool
lambda_vector_equal (lambda_vector vec1, lambda_vector vec2, int size)
{
  int i;
  for (i = 0; i < size; i++)
    if (vec1[i] != vec2[i])
      return false;
  return true;
}

/* Given an M x N integer matrix A, this function determines an M x
   M unimodular matrix U, and an M x N echelon matrix S such that
   "U.A = S".  This decomposition is also known as "right Hermite".

   Ref: Algorithm 2.1 page 33 in "Loop Transformations for
   Restructuring Compilers" Utpal Banerjee.  */

static void
lambda_matrix_right_hermite (lambda_matrix A, int m, int n,
			     lambda_matrix S, lambda_matrix U)
{
  int i, j, i0 = 0;

  lambda_matrix_copy (A, S, m, n);
  lambda_matrix_id (U, m);

  for (j = 0; j < n; j++)
    {
      if (lambda_vector_first_nz (S[j], m, i0) < m)
	{
	  ++i0;
	  for (i = m - 1; i >= i0; i--)
	    {
	      while (S[i][j] != 0)
		{
		  int sigma, factor, a, b;

		  a = S[i-1][j];
		  b = S[i][j];
		  sigma = (a * b < 0) ? -1: 1;
		  a = abs (a);
		  b = abs (b);
		  factor = sigma * (a / b);

		  lambda_matrix_row_add (S, n, i, i-1, -factor);
		  std::swap (S[i], S[i-1]);

		  lambda_matrix_row_add (U, m, i, i-1, -factor);
		  std::swap (U[i], U[i-1]);
		}
	    }
	}
    }
}

/* Determines the overlapping elements due to accesses CHREC_A and
   CHREC_B, that are affine functions.  This function cannot handle
   symbolic evolution functions, ie. when initial conditions are
   parameters, because it uses lambda matrices of integers.  */

static void
analyze_subscript_affine_affine (tree chrec_a,
				 tree chrec_b,
				 conflict_function **overlaps_a,
				 conflict_function **overlaps_b,
				 tree *last_conflicts)
{
  unsigned nb_vars_a, nb_vars_b, dim;
  HOST_WIDE_INT init_a, init_b, gamma, gcd_alpha_beta;
  lambda_matrix A, U, S;
  struct obstack scratch_obstack;

  if (eq_evolutions_p (chrec_a, chrec_b))
    {
      /* The accessed index overlaps for each iteration in the
	 loop.  */
      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *overlaps_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *last_conflicts = chrec_dont_know;
      return;
    }
  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "(analyze_subscript_affine_affine \n");

  /* For determining the initial intersection, we have to solve a
     Diophantine equation.  This is the most time consuming part.

     For answering to the question: "Is there a dependence?" we have
     to prove that there exists a solution to the Diophantine
     equation, and that the solution is in the iteration domain,
     i.e. the solution is positive or zero, and that the solution
     happens before the upper bound loop.nb_iterations.  Otherwise
     there is no dependence.  This function outputs a description of
     the iterations that hold the intersections.  */

  nb_vars_a = nb_vars_in_chrec (chrec_a);
  nb_vars_b = nb_vars_in_chrec (chrec_b);

  gcc_obstack_init (&scratch_obstack);

  dim = nb_vars_a + nb_vars_b;
  U = lambda_matrix_new (dim, dim, &scratch_obstack);
  A = lambda_matrix_new (dim, 1, &scratch_obstack);
  S = lambda_matrix_new (dim, 1, &scratch_obstack);

  init_a = int_cst_value (initialize_matrix_A (A, chrec_a, 0, 1));
  init_b = int_cst_value (initialize_matrix_A (A, chrec_b, nb_vars_a, -1));
  gamma = init_b - init_a;

  /* Don't do all the hard work of solving the Diophantine equation
     when we already know the solution: for example,
     | {3, +, 1}_1
     | {3, +, 4}_2
     | gamma = 3 - 3 = 0.
     Then the first overlap occurs during the first iterations:
     | {3, +, 1}_1 ({0, +, 4}_x) = {3, +, 4}_2 ({0, +, 1}_x)
  */
  if (gamma == 0)
    {
      if (nb_vars_a == 1 && nb_vars_b == 1)
	{
	  HOST_WIDE_INT step_a, step_b;
	  HOST_WIDE_INT niter, niter_a, niter_b;
	  affine_fn ova, ovb;

	  niter_a = max_stmt_executions_int (get_chrec_loop (chrec_a));
	  niter_b = max_stmt_executions_int (get_chrec_loop (chrec_b));
	  niter = MIN (niter_a, niter_b);
	  step_a = int_cst_value (CHREC_RIGHT (chrec_a));
	  step_b = int_cst_value (CHREC_RIGHT (chrec_b));

	  compute_overlap_steps_for_affine_univar (niter, step_a, step_b,
						   &ova, &ovb,
						   last_conflicts, 1);
	  *overlaps_a = conflict_fn (1, ova);
	  *overlaps_b = conflict_fn (1, ovb);
	}

      else if (nb_vars_a == 2 && nb_vars_b == 1)
	compute_overlap_steps_for_affine_1_2
	  (chrec_a, chrec_b, overlaps_a, overlaps_b, last_conflicts);

      else if (nb_vars_a == 1 && nb_vars_b == 2)
	compute_overlap_steps_for_affine_1_2
	  (chrec_b, chrec_a, overlaps_b, overlaps_a, last_conflicts);

      else
	{
	  if (dump_file && (dump_flags & TDF_DETAILS))
	    fprintf (dump_file, "affine-affine test failed: too many variables.\n");
	  *overlaps_a = conflict_fn_not_known ();
	  *overlaps_b = conflict_fn_not_known ();
	  *last_conflicts = chrec_dont_know;
	}
      goto end_analyze_subs_aa;
    }

  /* U.A = S */
  lambda_matrix_right_hermite (A, dim, 1, S, U);

  if (S[0][0] < 0)
    {
      S[0][0] *= -1;
      lambda_matrix_row_negate (U, dim, 0);
    }
  gcd_alpha_beta = S[0][0];

  /* Something went wrong: for example in {1, +, 0}_5 vs. {0, +, 0}_5,
     but that is a quite strange case.  Instead of ICEing, answer
     don't know.  */
  if (gcd_alpha_beta == 0)
    {
      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      goto end_analyze_subs_aa;
    }

  /* The classic "gcd-test".  */
  if (!int_divides_p (gcd_alpha_beta, gamma))
    {
      /* The "gcd-test" has determined that there is no integer
	 solution, i.e. there is no dependence.  */
      *overlaps_a = conflict_fn_no_dependence ();
      *overlaps_b = conflict_fn_no_dependence ();
      *last_conflicts = integer_zero_node;
    }

  /* Both access functions are univariate.  This includes SIV and MIV cases.  */
  else if (nb_vars_a == 1 && nb_vars_b == 1)
    {
      /* Both functions should have the same evolution sign.  */
      if (((A[0][0] > 0 && -A[1][0] > 0)
	   || (A[0][0] < 0 && -A[1][0] < 0)))
	{
	  /* The solutions are given by:
	     |
	     | [GAMMA/GCD_ALPHA_BETA  t].[u11 u12]  = [x0]
	     |                           [u21 u22]    [y0]

	     For a given integer t.  Using the following variables,

	     | i0 = u11 * gamma / gcd_alpha_beta
	     | j0 = u12 * gamma / gcd_alpha_beta
	     | i1 = u21
	     | j1 = u22

	     the solutions are:

	     | x0 = i0 + i1 * t,
	     | y0 = j0 + j1 * t.  */
      	  HOST_WIDE_INT i0, j0, i1, j1;

	  i0 = U[0][0] * gamma / gcd_alpha_beta;
	  j0 = U[0][1] * gamma / gcd_alpha_beta;
	  i1 = U[1][0];
	  j1 = U[1][1];

	  if ((i1 == 0 && i0 < 0)
	      || (j1 == 0 && j0 < 0))
	    {
	      /* There is no solution.
		 FIXME: The case "i0 > nb_iterations, j0 > nb_iterations"
		 falls in here, but for the moment we don't look at the
		 upper bound of the iteration domain.  */
	      *overlaps_a = conflict_fn_no_dependence ();
	      *overlaps_b = conflict_fn_no_dependence ();
	      *last_conflicts = integer_zero_node;
	      goto end_analyze_subs_aa;
	    }

	  if (i1 > 0 && j1 > 0)
	    {
	      HOST_WIDE_INT niter_a
		= max_stmt_executions_int (get_chrec_loop (chrec_a));
	      HOST_WIDE_INT niter_b
		= max_stmt_executions_int (get_chrec_loop (chrec_b));
	      HOST_WIDE_INT niter = MIN (niter_a, niter_b);

	      /* (X0, Y0) is a solution of the Diophantine equation:
		 "chrec_a (X0) = chrec_b (Y0)".  */
	      HOST_WIDE_INT tau1 = MAX (CEIL (-i0, i1),
					CEIL (-j0, j1));
	      HOST_WIDE_INT x0 = i1 * tau1 + i0;
	      HOST_WIDE_INT y0 = j1 * tau1 + j0;

	      /* (X1, Y1) is the smallest positive solution of the eq
		 "chrec_a (X1) = chrec_b (Y1)", i.e. this is where the
		 first conflict occurs.  */
	      HOST_WIDE_INT min_multiple = MIN (x0 / i1, y0 / j1);
	      HOST_WIDE_INT x1 = x0 - i1 * min_multiple;
	      HOST_WIDE_INT y1 = y0 - j1 * min_multiple;

	      if (niter > 0)
		{
		  HOST_WIDE_INT tau2 = MIN (FLOOR_DIV (niter_a - i0, i1),
					    FLOOR_DIV (niter_b - j0, j1));
		  HOST_WIDE_INT last_conflict = tau2 - (x1 - i0)/i1;

		  /* If the overlap occurs outside of the bounds of the
		     loop, there is no dependence.  */
		  if (x1 >= niter_a || y1 >= niter_b)
		    {
		      *overlaps_a = conflict_fn_no_dependence ();
		      *overlaps_b = conflict_fn_no_dependence ();
		      *last_conflicts = integer_zero_node;
		      goto end_analyze_subs_aa;
		    }
		  else
		    *last_conflicts = build_int_cst (NULL_TREE, last_conflict);
		}
	      else
		*last_conflicts = chrec_dont_know;

	      *overlaps_a
		= conflict_fn (1,
			       affine_fn_univar (build_int_cst (NULL_TREE, x1),
						 1,
						 build_int_cst (NULL_TREE, i1)));
	      *overlaps_b
		= conflict_fn (1,
			       affine_fn_univar (build_int_cst (NULL_TREE, y1),
						 1,
						 build_int_cst (NULL_TREE, j1)));
	    }
	  else
	    {
	      /* FIXME: For the moment, the upper bound of the
		 iteration domain for i and j is not checked.  */
	      if (dump_file && (dump_flags & TDF_DETAILS))
		fprintf (dump_file, "affine-affine test failed: unimplemented.\n");
	      *overlaps_a = conflict_fn_not_known ();
	      *overlaps_b = conflict_fn_not_known ();
	      *last_conflicts = chrec_dont_know;
	    }
	}
      else
	{
	  if (dump_file && (dump_flags & TDF_DETAILS))
	    fprintf (dump_file, "affine-affine test failed: unimplemented.\n");
	  *overlaps_a = conflict_fn_not_known ();
	  *overlaps_b = conflict_fn_not_known ();
	  *last_conflicts = chrec_dont_know;
	}
    }
  else
    {
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "affine-affine test failed: unimplemented.\n");
      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
    }

end_analyze_subs_aa:
  obstack_free (&scratch_obstack, NULL);
  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      fprintf (dump_file, "  (overlaps_a = ");
      dump_conflict_function (dump_file, *overlaps_a);
      fprintf (dump_file, ")\n  (overlaps_b = ");
      dump_conflict_function (dump_file, *overlaps_b);
      fprintf (dump_file, "))\n");
    }
}

/* Returns true when analyze_subscript_affine_affine can be used for
   determining the dependence relation between chrec_a and chrec_b,
   that contain symbols.  This function modifies chrec_a and chrec_b
   such that the analysis result is the same, and such that they don't
   contain symbols, and then can safely be passed to the analyzer.

   Example: The analysis of the following tuples of evolutions produce
   the same results: {x+1, +, 1}_1 vs. {x+3, +, 1}_1, and {-2, +, 1}_1
   vs. {0, +, 1}_1

   {x+1, +, 1}_1 ({2, +, 1}_1) = {x+3, +, 1}_1 ({0, +, 1}_1)
   {-2, +, 1}_1 ({2, +, 1}_1) = {0, +, 1}_1 ({0, +, 1}_1)
*/

static bool
can_use_analyze_subscript_affine_affine (tree *chrec_a, tree *chrec_b)
{
  tree diff, type, left_a, left_b, right_b;

  if (chrec_contains_symbols (CHREC_RIGHT (*chrec_a))
      || chrec_contains_symbols (CHREC_RIGHT (*chrec_b)))
    /* FIXME: For the moment not handled.  Might be refined later.  */
    return false;

  type = chrec_type (*chrec_a);
  left_a = CHREC_LEFT (*chrec_a);
  left_b = chrec_convert (type, CHREC_LEFT (*chrec_b), NULL);
  diff = chrec_fold_minus (type, left_a, left_b);

  if (!evolution_function_is_constant_p (diff))
    return false;

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "can_use_subscript_aff_aff_for_symbolic \n");

  *chrec_a = build_polynomial_chrec (CHREC_VARIABLE (*chrec_a),
				     diff, CHREC_RIGHT (*chrec_a));
  right_b = chrec_convert (type, CHREC_RIGHT (*chrec_b), NULL);
  *chrec_b = build_polynomial_chrec (CHREC_VARIABLE (*chrec_b),
				     build_int_cst (type, 0),
				     right_b);
  return true;
}

/* Analyze a SIV (Single Index Variable) subscript.  *OVERLAPS_A and
   *OVERLAPS_B are initialized to the functions that describe the
   relation between the elements accessed twice by CHREC_A and
   CHREC_B.  For k >= 0, the following property is verified:

   CHREC_A (*OVERLAPS_A (k)) = CHREC_B (*OVERLAPS_B (k)).  */

static void
analyze_siv_subscript (tree chrec_a,
		       tree chrec_b,
		       conflict_function **overlaps_a,
		       conflict_function **overlaps_b,
		       tree *last_conflicts,
		       int loop_nest_num)
{
  dependence_stats.num_siv++;

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "(analyze_siv_subscript \n");

  if (evolution_function_is_constant_p (chrec_a)
      && evolution_function_is_affine_in_loop (chrec_b, loop_nest_num))
    analyze_siv_subscript_cst_affine (chrec_a, chrec_b,
				      overlaps_a, overlaps_b, last_conflicts);

  else if (evolution_function_is_affine_in_loop (chrec_a, loop_nest_num)
	   && evolution_function_is_constant_p (chrec_b))
    analyze_siv_subscript_cst_affine (chrec_b, chrec_a,
				      overlaps_b, overlaps_a, last_conflicts);

  else if (evolution_function_is_affine_in_loop (chrec_a, loop_nest_num)
	   && evolution_function_is_affine_in_loop (chrec_b, loop_nest_num))
    {
      if (!chrec_contains_symbols (chrec_a)
	  && !chrec_contains_symbols (chrec_b))
	{
	  analyze_subscript_affine_affine (chrec_a, chrec_b,
					   overlaps_a, overlaps_b,
					   last_conflicts);

	  if (CF_NOT_KNOWN_P (*overlaps_a)
	      || CF_NOT_KNOWN_P (*overlaps_b))
	    dependence_stats.num_siv_unimplemented++;
	  else if (CF_NO_DEPENDENCE_P (*overlaps_a)
		   || CF_NO_DEPENDENCE_P (*overlaps_b))
	    dependence_stats.num_siv_independent++;
	  else
	    dependence_stats.num_siv_dependent++;
	}
      else if (can_use_analyze_subscript_affine_affine (&chrec_a,
							&chrec_b))
	{
	  analyze_subscript_affine_affine (chrec_a, chrec_b,
					   overlaps_a, overlaps_b,
					   last_conflicts);

	  if (CF_NOT_KNOWN_P (*overlaps_a)
	      || CF_NOT_KNOWN_P (*overlaps_b))
	    dependence_stats.num_siv_unimplemented++;
	  else if (CF_NO_DEPENDENCE_P (*overlaps_a)
		   || CF_NO_DEPENDENCE_P (*overlaps_b))
	    dependence_stats.num_siv_independent++;
	  else
	    dependence_stats.num_siv_dependent++;
	}
      else
	goto siv_subscript_dontknow;
    }

  else
    {
    siv_subscript_dontknow:;
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "  siv test failed: unimplemented");
      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      dependence_stats.num_siv_unimplemented++;
    }

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, ")\n");
}

/* Returns false if we can prove that the greatest common divisor of the steps
   of CHREC does not divide CST, false otherwise.  */

static bool
gcd_of_steps_may_divide_p (const_tree chrec, const_tree cst)
{
  HOST_WIDE_INT cd = 0, val;
  tree step;

  if (!tree_fits_shwi_p (cst))
    return true;
  val = tree_to_shwi (cst);

  while (TREE_CODE (chrec) == POLYNOMIAL_CHREC)
    {
      step = CHREC_RIGHT (chrec);
      if (!tree_fits_shwi_p (step))
	return true;
      cd = gcd (cd, tree_to_shwi (step));
      chrec = CHREC_LEFT (chrec);
    }

  return val % cd == 0;
}

/* Analyze a MIV (Multiple Index Variable) subscript with respect to
   LOOP_NEST.  *OVERLAPS_A and *OVERLAPS_B are initialized to the
   functions that describe the relation between the elements accessed
   twice by CHREC_A and CHREC_B.  For k >= 0, the following property
   is verified:

   CHREC_A (*OVERLAPS_A (k)) = CHREC_B (*OVERLAPS_B (k)).  */

static void
analyze_miv_subscript (tree chrec_a,
		       tree chrec_b,
		       conflict_function **overlaps_a,
		       conflict_function **overlaps_b,
		       tree *last_conflicts,
		       struct loop *loop_nest)
{
  tree type, difference;

  dependence_stats.num_miv++;
  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, "(analyze_miv_subscript \n");

  type = signed_type_for_types (TREE_TYPE (chrec_a), TREE_TYPE (chrec_b));
  chrec_a = chrec_convert (type, chrec_a, NULL);
  chrec_b = chrec_convert (type, chrec_b, NULL);
  difference = chrec_fold_minus (type, chrec_a, chrec_b);

  if (eq_evolutions_p (chrec_a, chrec_b))
    {
      /* Access functions are the same: all the elements are accessed
	 in the same order.  */
      *overlaps_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *overlaps_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *last_conflicts = max_stmt_executions_tree (get_chrec_loop (chrec_a));
      dependence_stats.num_miv_dependent++;
    }

  else if (evolution_function_is_constant_p (difference)
	   /* For the moment, the following is verified:
	      evolution_function_is_affine_multivariate_p (chrec_a,
	      loop_nest->num) */
	   && !gcd_of_steps_may_divide_p (chrec_a, difference))
    {
      /* testsuite/.../ssa-chrec-33.c
	 {{21, +, 2}_1, +, -2}_2  vs.  {{20, +, 2}_1, +, -2}_2

	 The difference is 1, and all the evolution steps are multiples
	 of 2, consequently there are no overlapping elements.  */
      *overlaps_a = conflict_fn_no_dependence ();
      *overlaps_b = conflict_fn_no_dependence ();
      *last_conflicts = integer_zero_node;
      dependence_stats.num_miv_independent++;
    }

  else if (evolution_function_is_affine_multivariate_p (chrec_a, loop_nest->num)
	   && !chrec_contains_symbols (chrec_a)
	   && evolution_function_is_affine_multivariate_p (chrec_b, loop_nest->num)
	   && !chrec_contains_symbols (chrec_b))
    {
      /* testsuite/.../ssa-chrec-35.c
	 {0, +, 1}_2  vs.  {0, +, 1}_3
	 the overlapping elements are respectively located at iterations:
	 {0, +, 1}_x and {0, +, 1}_x,
	 in other words, we have the equality:
	 {0, +, 1}_2 ({0, +, 1}_x) = {0, +, 1}_3 ({0, +, 1}_x)

	 Other examples:
	 {{0, +, 1}_1, +, 2}_2 ({0, +, 1}_x, {0, +, 1}_y) =
	 {0, +, 1}_1 ({{0, +, 1}_x, +, 2}_y)

	 {{0, +, 2}_1, +, 3}_2 ({0, +, 1}_y, {0, +, 1}_x) =
	 {{0, +, 3}_1, +, 2}_2 ({0, +, 1}_x, {0, +, 1}_y)
      */
      analyze_subscript_affine_affine (chrec_a, chrec_b,
				       overlaps_a, overlaps_b, last_conflicts);

      if (CF_NOT_KNOWN_P (*overlaps_a)
 	  || CF_NOT_KNOWN_P (*overlaps_b))
	dependence_stats.num_miv_unimplemented++;
      else if (CF_NO_DEPENDENCE_P (*overlaps_a)
	       || CF_NO_DEPENDENCE_P (*overlaps_b))
	dependence_stats.num_miv_independent++;
      else
	dependence_stats.num_miv_dependent++;
    }

  else
    {
      /* When the analysis is too difficult, answer "don't know".  */
      if (dump_file && (dump_flags & TDF_DETAILS))
	fprintf (dump_file, "analyze_miv_subscript test failed: unimplemented.\n");

      *overlaps_a = conflict_fn_not_known ();
      *overlaps_b = conflict_fn_not_known ();
      *last_conflicts = chrec_dont_know;
      dependence_stats.num_miv_unimplemented++;
    }

  if (dump_file && (dump_flags & TDF_DETAILS))
    fprintf (dump_file, ")\n");
}

/* Determines the iterations for which CHREC_A is equal to CHREC_B in
   with respect to LOOP_NEST.  OVERLAP_ITERATIONS_A and
   OVERLAP_ITERATIONS_B are initialized with two functions that
   describe the iterations that contain conflicting elements.

   Remark: For an integer k >= 0, the following equality is true:

   CHREC_A (OVERLAP_ITERATIONS_A (k)) == CHREC_B (OVERLAP_ITERATIONS_B (k)).
*/

static void
analyze_overlapping_iterations (tree chrec_a,
				tree chrec_b,
				conflict_function **overlap_iterations_a,
				conflict_function **overlap_iterations_b,
				tree *last_conflicts, struct loop *loop_nest)
{
  unsigned int lnn = loop_nest->num;

  dependence_stats.num_subscript_tests++;

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      fprintf (dump_file, "(analyze_overlapping_iterations \n");
      fprintf (dump_file, "  (chrec_a = ");
      print_generic_expr (dump_file, chrec_a);
      fprintf (dump_file, ")\n  (chrec_b = ");
      print_generic_expr (dump_file, chrec_b);
      fprintf (dump_file, ")\n");
    }

  if (chrec_a == NULL_TREE
      || chrec_b == NULL_TREE
      || chrec_contains_undetermined (chrec_a)
      || chrec_contains_undetermined (chrec_b))
    {
      dependence_stats.num_subscript_undetermined++;

      *overlap_iterations_a = conflict_fn_not_known ();
      *overlap_iterations_b = conflict_fn_not_known ();
    }

  /* If they are the same chrec, and are affine, they overlap
     on every iteration.  */
  else if (eq_evolutions_p (chrec_a, chrec_b)
	   && (evolution_function_is_affine_multivariate_p (chrec_a, lnn)
	       || operand_equal_p (chrec_a, chrec_b, 0)))
    {
      dependence_stats.num_same_subscript_function++;
      *overlap_iterations_a = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *overlap_iterations_b = conflict_fn (1, affine_fn_cst (integer_zero_node));
      *last_conflicts = chrec_dont_know;
    }

  /* If they aren't the same, and aren't affine, we can't do anything
     yet.  */
  else if ((chrec_contains_symbols (chrec_a)
	    || chrec_contains_symbols (chrec_b))
	   && (!evolution_function_is_affine_multivariate_p (chrec_a, lnn)
	       || !evolution_function_is_affine_multivariate_p (chrec_b, lnn)))
    {
      dependence_stats.num_subscript_undetermined++;
      *overlap_iterations_a = conflict_fn_not_known ();
      *overlap_iterations_b = conflict_fn_not_known ();
    }

  else if (ziv_subscript_p (chrec_a, chrec_b))
    analyze_ziv_subscript (chrec_a, chrec_b,
			   overlap_iterations_a, overlap_iterations_b,
			   last_conflicts);

  else if (siv_subscript_p (chrec_a, chrec_b))
    analyze_siv_subscript (chrec_a, chrec_b,
			   overlap_iterations_a, overlap_iterations_b,
			   last_conflicts, lnn);

  else
    analyze_miv_subscript (chrec_a, chrec_b,
			   overlap_iterations_a, overlap_iterations_b,
			   last_conflicts, loop_nest);

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      fprintf (dump_file, "  (overlap_iterations_a = ");
      dump_conflict_function (dump_file, *overlap_iterations_a);
      fprintf (dump_file, ")\n  (overlap_iterations_b = ");
      dump_conflict_function (dump_file, *overlap_iterations_b);
      fprintf (dump_file, "))\n");
    }
}

/* Helper function for uniquely inserting distance vectors.  */

static void
save_dist_v (struct data_dependence_relation *ddr, lambda_vector dist_v)
{
  unsigned i;
  lambda_vector v;

  FOR_EACH_VEC_ELT (DDR_DIST_VECTS (ddr), i, v)
    if (lambda_vector_equal (v, dist_v, DDR_NB_LOOPS (ddr)))
      return;

  DDR_DIST_VECTS (ddr).safe_push (dist_v);
}

/* Helper function for uniquely inserting direction vectors.  */

static void
save_dir_v (struct data_dependence_relation *ddr, lambda_vector dir_v)
{
  unsigned i;
  lambda_vector v;

  FOR_EACH_VEC_ELT (DDR_DIR_VECTS (ddr), i, v)
    if (lambda_vector_equal (v, dir_v, DDR_NB_LOOPS (ddr)))
      return;

  DDR_DIR_VECTS (ddr).safe_push (dir_v);
}

/* Add a distance of 1 on all the loops outer than INDEX.  If we
   haven't yet determined a distance for this outer loop, push a new
   distance vector composed of the previous distance, and a distance
   of 1 for this outer loop.  Example:

   | loop_1
   |   loop_2
   |     A[10]
   |   endloop_2
   | endloop_1

   Saved vectors are of the form (dist_in_1, dist_in_2).  First, we
   save (0, 1), then we have to save (1, 0).  */

static void
add_outer_distances (struct data_dependence_relation *ddr,
		     lambda_vector dist_v, int index)
{
  /* For each outer loop where init_v is not set, the accesses are
     in dependence of distance 1 in the loop.  */
  while (--index >= 0)
    {
      lambda_vector save_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
      lambda_vector_copy (dist_v, save_v, DDR_NB_LOOPS (ddr));
      save_v[index] = 1;
      save_dist_v (ddr, save_v);
    }
}

/* Return false when fail to represent the data dependence as a
   distance vector.  A_INDEX is the index of the first reference
   (0 for DDR_A, 1 for DDR_B) and B_INDEX is the index of the
   second reference.  INIT_B is set to true when a component has been
   added to the distance vector DIST_V.  INDEX_CARRY is then set to
   the index in DIST_V that carries the dependence.  */

static bool
build_classic_dist_vector_1 (struct data_dependence_relation *ddr,
			     unsigned int a_index, unsigned int b_index,
			     lambda_vector dist_v, bool *init_b,
			     int *index_carry)
{
  unsigned i;
  lambda_vector init_v = lambda_vector_new (DDR_NB_LOOPS (ddr));

  for (i = 0; i < DDR_NUM_SUBSCRIPTS (ddr); i++)
    {
      tree access_fn_a, access_fn_b;
      struct subscript *subscript = DDR_SUBSCRIPT (ddr, i);

      if (chrec_contains_undetermined (SUB_DISTANCE (subscript)))
	{
	  non_affine_dependence_relation (ddr);
	  return false;
	}

      access_fn_a = SUB_ACCESS_FN (subscript, a_index);
      access_fn_b = SUB_ACCESS_FN (subscript, b_index);

      if (TREE_CODE (access_fn_a) == POLYNOMIAL_CHREC
	  && TREE_CODE (access_fn_b) == POLYNOMIAL_CHREC)
	{
	  HOST_WIDE_INT dist;
	  int index;
	  int var_a = CHREC_VARIABLE (access_fn_a);
	  int var_b = CHREC_VARIABLE (access_fn_b);

	  if (var_a != var_b
	      || chrec_contains_undetermined (SUB_DISTANCE (subscript)))
	    {
	      non_affine_dependence_relation (ddr);
	      return false;
	    }

	  dist = int_cst_value (SUB_DISTANCE (subscript));
	  index = index_in_loop_nest (var_a, DDR_LOOP_NEST (ddr));
	  *index_carry = MIN (index, *index_carry);

	  /* This is the subscript coupling test.  If we have already
	     recorded a distance for this loop (a distance coming from
	     another subscript), it should be the same.  For example,
	     in the following code, there is no dependence:

	     | loop i = 0, N, 1
	     |   T[i+1][i] = ...
	     |   ... = T[i][i]
	     | endloop
	  */
	  if (init_v[index] != 0 && dist_v[index] != dist)
	    {
	      finalize_ddr_dependent (ddr, chrec_known);
	      return false;
	    }

	  dist_v[index] = dist;
	  init_v[index] = 1;
	  *init_b = true;
	}
      else if (!operand_equal_p (access_fn_a, access_fn_b, 0))
	{
	  /* This can be for example an affine vs. constant dependence
	     (T[i] vs. T[3]) that is not an affine dependence and is
	     not representable as a distance vector.  */
	  non_affine_dependence_relation (ddr);
	  return false;
	}
    }

  return true;
}

/* Return true when the DDR contains only constant access functions.  */

static bool
constant_access_functions (const struct data_dependence_relation *ddr)
{
  unsigned i;
  subscript *sub;

  FOR_EACH_VEC_ELT (DDR_SUBSCRIPTS (ddr), i, sub)
    if (!evolution_function_is_constant_p (SUB_ACCESS_FN (sub, 0))
	|| !evolution_function_is_constant_p (SUB_ACCESS_FN (sub, 1)))
      return false;

  return true;
}

/* Helper function for the case where DDR_A and DDR_B are the same
   multivariate access function with a constant step.  For an example
   see pr34635-1.c.  */

static void
add_multivariate_self_dist (struct data_dependence_relation *ddr, tree c_2)
{
  int x_1, x_2;
  tree c_1 = CHREC_LEFT (c_2);
  tree c_0 = CHREC_LEFT (c_1);
  lambda_vector dist_v;
  HOST_WIDE_INT v1, v2, cd;

  /* Polynomials with more than 2 variables are not handled yet.  When
     the evolution steps are parameters, it is not possible to
     represent the dependence using classical distance vectors.  */
  if (TREE_CODE (c_0) != INTEGER_CST
      || TREE_CODE (CHREC_RIGHT (c_1)) != INTEGER_CST
      || TREE_CODE (CHREC_RIGHT (c_2)) != INTEGER_CST)
    {
      DDR_AFFINE_P (ddr) = false;
      return;
    }

  x_2 = index_in_loop_nest (CHREC_VARIABLE (c_2), DDR_LOOP_NEST (ddr));
  x_1 = index_in_loop_nest (CHREC_VARIABLE (c_1), DDR_LOOP_NEST (ddr));

  /* For "{{0, +, 2}_1, +, 3}_2" the distance vector is (3, -2).  */
  dist_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
  v1 = int_cst_value (CHREC_RIGHT (c_1));
  v2 = int_cst_value (CHREC_RIGHT (c_2));
  cd = gcd (v1, v2);
  v1 /= cd;
  v2 /= cd;

  if (v2 < 0)
    {
      v2 = -v2;
      v1 = -v1;
    }

  dist_v[x_1] = v2;
  dist_v[x_2] = -v1;
  save_dist_v (ddr, dist_v);

  add_outer_distances (ddr, dist_v, x_1);
}

/* Helper function for the case where DDR_A and DDR_B are the same
   access functions.  */

static void
add_other_self_distances (struct data_dependence_relation *ddr)
{
  lambda_vector dist_v;
  unsigned i;
  int index_carry = DDR_NB_LOOPS (ddr);
  subscript *sub;

  FOR_EACH_VEC_ELT (DDR_SUBSCRIPTS (ddr), i, sub)
    {
      tree access_fun = SUB_ACCESS_FN (sub, 0);

      if (TREE_CODE (access_fun) == POLYNOMIAL_CHREC)
	{
	  if (!evolution_function_is_univariate_p (access_fun))
	    {
	      if (DDR_NUM_SUBSCRIPTS (ddr) != 1)
		{
		  DDR_ARE_DEPENDENT (ddr) = chrec_dont_know;
		  return;
		}

	      access_fun = SUB_ACCESS_FN (DDR_SUBSCRIPT (ddr, 0), 0);

	      if (TREE_CODE (CHREC_LEFT (access_fun)) == POLYNOMIAL_CHREC)
		add_multivariate_self_dist (ddr, access_fun);
	      else
		/* The evolution step is not constant: it varies in
		   the outer loop, so this cannot be represented by a
		   distance vector.  For example in pr34635.c the
		   evolution is {0, +, {0, +, 4}_1}_2.  */
		DDR_AFFINE_P (ddr) = false;

	      return;
	    }

	  index_carry = MIN (index_carry,
			     index_in_loop_nest (CHREC_VARIABLE (access_fun),
						 DDR_LOOP_NEST (ddr)));
	}
    }

  dist_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
  add_outer_distances (ddr, dist_v, index_carry);
}

static void
insert_innermost_unit_dist_vector (struct data_dependence_relation *ddr)
{
  lambda_vector dist_v = lambda_vector_new (DDR_NB_LOOPS (ddr));

  dist_v[DDR_INNER_LOOP (ddr)] = 1;
  save_dist_v (ddr, dist_v);
}

/* Adds a unit distance vector to DDR when there is a 0 overlap.  This
   is the case for example when access functions are the same and
   equal to a constant, as in:

   | loop_1
   |   A[3] = ...
   |   ... = A[3]
   | endloop_1

   in which case the distance vectors are (0) and (1).  */

static void
add_distance_for_zero_overlaps (struct data_dependence_relation *ddr)
{
  unsigned i, j;

  for (i = 0; i < DDR_NUM_SUBSCRIPTS (ddr); i++)
    {
      subscript_p sub = DDR_SUBSCRIPT (ddr, i);
      conflict_function *ca = SUB_CONFLICTS_IN_A (sub);
      conflict_function *cb = SUB_CONFLICTS_IN_B (sub);

      for (j = 0; j < ca->n; j++)
	if (affine_function_zero_p (ca->fns[j]))
	  {
	    insert_innermost_unit_dist_vector (ddr);
	    return;
	  }

      for (j = 0; j < cb->n; j++)
	if (affine_function_zero_p (cb->fns[j]))
	  {
	    insert_innermost_unit_dist_vector (ddr);
	    return;
	  }
    }
}

/* Return true when the DDR contains two data references that have the
   same access functions.  */

static inline bool
same_access_functions (const struct data_dependence_relation *ddr)
{
  unsigned i;
  subscript *sub;

  FOR_EACH_VEC_ELT (DDR_SUBSCRIPTS (ddr), i, sub)
    if (!eq_evolutions_p (SUB_ACCESS_FN (sub, 0),
			  SUB_ACCESS_FN (sub, 1)))
      return false;

  return true;
}

/* Compute the classic per loop distance vector.  DDR is the data
   dependence relation to build a vector from.  Return false when fail
   to represent the data dependence as a distance vector.  */

static bool
build_classic_dist_vector (struct data_dependence_relation *ddr,
			   struct loop *loop_nest)
{
  bool init_b = false;
  int index_carry = DDR_NB_LOOPS (ddr);
  lambda_vector dist_v;

  if (DDR_ARE_DEPENDENT (ddr) != NULL_TREE)
    return false;

  if (same_access_functions (ddr))
    {
      /* Save the 0 vector.  */
      dist_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
      save_dist_v (ddr, dist_v);

      if (constant_access_functions (ddr))
	add_distance_for_zero_overlaps (ddr);

      if (DDR_NB_LOOPS (ddr) > 1)
	add_other_self_distances (ddr);

      return true;
    }

  dist_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
  if (!build_classic_dist_vector_1 (ddr, 0, 1, dist_v, &init_b, &index_carry))
    return false;

  /* Save the distance vector if we initialized one.  */
  if (init_b)
    {
      /* Verify a basic constraint: classic distance vectors should
	 always be lexicographically positive.

	 Data references are collected in the order of execution of
	 the program, thus for the following loop

	 | for (i = 1; i < 100; i++)
	 |   for (j = 1; j < 100; j++)
	 |     {
	 |       t = T[j+1][i-1];  // A
	 |       T[j][i] = t + 2;  // B
	 |     }

	 references are collected following the direction of the wind:
	 A then B.  The data dependence tests are performed also
	 following this order, such that we're looking at the distance
	 separating the elements accessed by A from the elements later
	 accessed by B.  But in this example, the distance returned by
	 test_dep (A, B) is lexicographically negative (-1, 1), that
	 means that the access A occurs later than B with respect to
	 the outer loop, ie. we're actually looking upwind.  In this
	 case we solve test_dep (B, A) looking downwind to the
	 lexicographically positive solution, that returns the
	 distance vector (1, -1).  */
      if (!lambda_vector_lexico_pos (dist_v, DDR_NB_LOOPS (ddr)))
	{
	  lambda_vector save_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
	  if (!subscript_dependence_tester_1 (ddr, 1, 0, loop_nest))
	    return false;
	  compute_subscript_distance (ddr);
	  if (!build_classic_dist_vector_1 (ddr, 1, 0, save_v, &init_b,
					    &index_carry))
	    return false;
	  save_dist_v (ddr, save_v);
	  DDR_REVERSED_P (ddr) = true;

	  /* In this case there is a dependence forward for all the
	     outer loops:

	     | for (k = 1; k < 100; k++)
	     |  for (i = 1; i < 100; i++)
	     |   for (j = 1; j < 100; j++)
	     |     {
	     |       t = T[j+1][i-1];  // A
	     |       T[j][i] = t + 2;  // B
	     |     }

	     the vectors are:
	     (0,  1, -1)
	     (1,  1, -1)
	     (1, -1,  1)
	  */
	  if (DDR_NB_LOOPS (ddr) > 1)
	    {
 	      add_outer_distances (ddr, save_v, index_carry);
	      add_outer_distances (ddr, dist_v, index_carry);
	    }
	}
      else
	{
	  lambda_vector save_v = lambda_vector_new (DDR_NB_LOOPS (ddr));
	  lambda_vector_copy (dist_v, save_v, DDR_NB_LOOPS (ddr));

	  if (DDR_NB_LOOPS (ddr) > 1)
	    {
	      lambda_vector opposite_v = lambda_vector_new (DDR_NB_LOOPS (ddr));

	      if (!subscript_dependence_tester_1 (ddr, 1, 0, loop_nest))
		return false;
	      compute_subscript_distance (ddr);
	      if (!build_classic_dist_vector_1 (ddr, 1, 0, opposite_v, &init_b,
						&index_carry))
		return false;

	      save_dist_v (ddr, save_v);
	      add_outer_distances (ddr, dist_v, index_carry);
	      add_outer_distances (ddr, opposite_v, index_carry);
	    }
	  else
	    save_dist_v (ddr, save_v);
	}
    }
  else
    {
      /* There is a distance of 1 on all the outer loops: Example:
	 there is a dependence of distance 1 on loop_1 for the array A.

	 | loop_1
	 |   A[5] = ...
	 | endloop
      */
      add_outer_distances (ddr, dist_v,
			   lambda_vector_first_nz (dist_v,
						   DDR_NB_LOOPS (ddr), 0));
    }

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      unsigned i;

      fprintf (dump_file, "(build_classic_dist_vector\n");
      for (i = 0; i < DDR_NUM_DIST_VECTS (ddr); i++)
	{
	  fprintf (dump_file, "  dist_vector = (");
	  print_lambda_vector (dump_file, DDR_DIST_VECT (ddr, i),
			       DDR_NB_LOOPS (ddr));
	  fprintf (dump_file, "  )\n");
	}
      fprintf (dump_file, ")\n");
    }

  return true;
}

/* Return the direction for a given distance.
   FIXME: Computing dir this way is suboptimal, since dir can catch
   cases that dist is unable to represent.  */

static inline enum data_dependence_direction
dir_from_dist (int dist)
{
  if (dist > 0)
    return dir_positive;
  else if (dist < 0)
    return dir_negative;
  else
    return dir_equal;
}

/* Compute the classic per loop direction vector.  DDR is the data
   dependence relation to build a vector from.  */

static void
build_classic_dir_vector (struct data_dependence_relation *ddr)
{
  unsigned i, j;
  lambda_vector dist_v;

  FOR_EACH_VEC_ELT (DDR_DIST_VECTS (ddr), i, dist_v)
    {
      lambda_vector dir_v = lambda_vector_new (DDR_NB_LOOPS (ddr));

      for (j = 0; j < DDR_NB_LOOPS (ddr); j++)
	dir_v[j] = dir_from_dist (dist_v[j]);

      save_dir_v (ddr, dir_v);
    }
}

/* Helper function.  Returns true when there is a dependence between the
   data references.  A_INDEX is the index of the first reference (0 for
   DDR_A, 1 for DDR_B) and B_INDEX is the index of the second reference.  */

static bool
subscript_dependence_tester_1 (struct data_dependence_relation *ddr,
			       unsigned int a_index, unsigned int b_index,
			       struct loop *loop_nest)
{
  unsigned int i;
  tree last_conflicts;
  struct subscript *subscript;
  tree res = NULL_TREE;

  for (i = 0; DDR_SUBSCRIPTS (ddr).iterate (i, &subscript); i++)
    {
      conflict_function *overlaps_a, *overlaps_b;

      analyze_overlapping_iterations (SUB_ACCESS_FN (subscript, a_index),
				      SUB_ACCESS_FN (subscript, b_index),
				      &overlaps_a, &overlaps_b,
				      &last_conflicts, loop_nest);

      if (SUB_CONFLICTS_IN_A (subscript))
	free_conflict_function (SUB_CONFLICTS_IN_A (subscript));
      if (SUB_CONFLICTS_IN_B (subscript))
	free_conflict_function (SUB_CONFLICTS_IN_B (subscript));

      SUB_CONFLICTS_IN_A (subscript) = overlaps_a;
      SUB_CONFLICTS_IN_B (subscript) = overlaps_b;
      SUB_LAST_CONFLICT (subscript) = last_conflicts;

      /* If there is any undetermined conflict function we have to
         give a conservative answer in case we cannot prove that
	 no dependence exists when analyzing another subscript.  */
      if (CF_NOT_KNOWN_P (overlaps_a)
 	  || CF_NOT_KNOWN_P (overlaps_b))
 	{
	  res = chrec_dont_know;
	  continue;
 	}

      /* When there is a subscript with no dependence we can stop.  */
      else if (CF_NO_DEPENDENCE_P (overlaps_a)
 	       || CF_NO_DEPENDENCE_P (overlaps_b))
 	{
	  res = chrec_known;
	  break;
 	}
    }

  if (res == NULL_TREE)
    return true;

  if (res == chrec_known)
    dependence_stats.num_dependence_independent++;
  else
    dependence_stats.num_dependence_undetermined++;
  finalize_ddr_dependent (ddr, res);
  return false;
}

/* Computes the conflicting iterations in LOOP_NEST, and initialize DDR.  */

static void
subscript_dependence_tester (struct data_dependence_relation *ddr,
			     struct loop *loop_nest)
{
  if (subscript_dependence_tester_1 (ddr, 0, 1, loop_nest))
    dependence_stats.num_dependence_dependent++;

  compute_subscript_distance (ddr);
  if (build_classic_dist_vector (ddr, loop_nest))
    build_classic_dir_vector (ddr);
}

/* Returns true when all the access functions of A are affine or
   constant with respect to LOOP_NEST.  */

static bool
access_functions_are_affine_or_constant_p (const struct data_reference *a,
					   const struct loop *loop_nest)
{
  unsigned int i;
  vec<tree> fns = DR_ACCESS_FNS (a);
  tree t;

  FOR_EACH_VEC_ELT (fns, i, t)
    if (!evolution_function_is_invariant_p (t, loop_nest->num)
	&& !evolution_function_is_affine_multivariate_p (t, loop_nest->num))
      return false;

  return true;
}

/* This computes the affine dependence relation between A and B with
   respect to LOOP_NEST.  CHREC_KNOWN is used for representing the
   independence between two accesses, while CHREC_DONT_KNOW is used
   for representing the unknown relation.

   Note that it is possible to stop the computation of the dependence
   relation the first time we detect a CHREC_KNOWN element for a given
   subscript.  */

void
compute_affine_dependence (struct data_dependence_relation *ddr,
			   struct loop *loop_nest)
{
  struct data_reference *dra = DDR_A (ddr);
  struct data_reference *drb = DDR_B (ddr);

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      fprintf (dump_file, "(compute_affine_dependence\n");
      fprintf (dump_file, "  stmt_a: ");
      print_gimple_stmt (dump_file, DR_STMT (dra), 0, TDF_SLIM);
      fprintf (dump_file, "  stmt_b: ");
      print_gimple_stmt (dump_file, DR_STMT (drb), 0, TDF_SLIM);
    }

  /* Analyze only when the dependence relation is not yet known.  */
  if (DDR_ARE_DEPENDENT (ddr) == NULL_TREE)
    {
      dependence_stats.num_dependence_tests++;

      if (access_functions_are_affine_or_constant_p (dra, loop_nest)
	  && access_functions_are_affine_or_constant_p (drb, loop_nest))
	subscript_dependence_tester (ddr, loop_nest);

      /* As a last case, if the dependence cannot be determined, or if
	 the dependence is considered too difficult to determine, answer
	 "don't know".  */
      else
	{
	  dependence_stats.num_dependence_undetermined++;

	  if (dump_file && (dump_flags & TDF_DETAILS))
	    {
	      fprintf (dump_file, "Data ref a:\n");
	      dump_data_reference (dump_file, dra);
	      fprintf (dump_file, "Data ref b:\n");
	      dump_data_reference (dump_file, drb);
	      fprintf (dump_file, "affine dependence test not usable: access function not affine or constant.\n");
	    }
	  finalize_ddr_dependent (ddr, chrec_dont_know);
	}
    }

  if (dump_file && (dump_flags & TDF_DETAILS))
    {
      if (DDR_ARE_DEPENDENT (ddr) == chrec_known)
	fprintf (dump_file, ") -> no dependence\n");
      else if (DDR_ARE_DEPENDENT (ddr) == chrec_dont_know)
	fprintf (dump_file, ") -> dependence analysis failed\n");
      else
	fprintf (dump_file, ")\n");
    }
}

/* Compute in DEPENDENCE_RELATIONS the data dependence graph for all
   the data references in DATAREFS, in the LOOP_NEST.  When
   COMPUTE_SELF_AND_RR is FALSE, don't compute read-read and self
   relations.  Return true when successful, i.e. data references number
   is small enough to be handled.  */

bool
compute_all_dependences (vec<data_reference_p> datarefs,
			 vec<ddr_p> *dependence_relations,
			 vec<loop_p> loop_nest,
			 bool compute_self_and_rr)
{
  struct data_dependence_relation *ddr;
  struct data_reference *a, *b;
  unsigned int i, j;

  if ((int) datarefs.length ()
      > PARAM_VALUE (PARAM_LOOP_MAX_DATAREFS_FOR_DATADEPS))
    {
      struct data_dependence_relation *ddr;

      /* Insert a single relation into dependence_relations:
	 chrec_dont_know.  */
      ddr = initialize_data_dependence_relation (NULL, NULL, loop_nest);
      dependence_relations->safe_push (ddr);
      return false;
    }

  FOR_EACH_VEC_ELT (datarefs, i, a)
    for (j = i + 1; datarefs.iterate (j, &b); j++)
      if (DR_IS_WRITE (a) || DR_IS_WRITE (b) || compute_self_and_rr)
	{
	  ddr = initialize_data_dependence_relation (a, b, loop_nest);
	  dependence_relations->safe_push (ddr);
          if (loop_nest.exists ())
   	    compute_affine_dependence (ddr, loop_nest[0]);
	}

  if (compute_self_and_rr)
    FOR_EACH_VEC_ELT (datarefs, i, a)
      {
	ddr = initialize_data_dependence_relation (a, a, loop_nest);
	dependence_relations->safe_push (ddr);
        if (loop_nest.exists ())
   	  compute_affine_dependence (ddr, loop_nest[0]);
      }

  return true;
}

/* Describes a location of a memory reference.  */

struct data_ref_loc
{
  /* The memory reference.  */
  tree ref;

  /* True if the memory reference is read.  */
  bool is_read;

  /* True if the data reference is conditional within the containing
     statement, i.e. if it might not occur even when the statement
     is executed and runs to completion.  */
  bool is_conditional_in_stmt;
};


/* Stores the locations of memory references in STMT to REFERENCES.  Returns
   true if STMT clobbers memory, false otherwise.  */

static bool
get_references_in_stmt (gimple *stmt, vec<data_ref_loc, va_heap> *references)
{
  bool clobbers_memory = false;
  data_ref_loc ref;
  tree op0, op1;
  enum gimple_code stmt_code = gimple_code (stmt);

  /* ASM_EXPR and CALL_EXPR may embed arbitrary side effects.
     As we cannot model data-references to not spelled out
     accesses give up if they may occur.  */
  if (stmt_code == GIMPLE_CALL
      && !(gimple_call_flags (stmt) & ECF_CONST))
    {
      /* Allow IFN_GOMP_SIMD_LANE in their own loops.  */
      if (gimple_call_internal_p (stmt))
	switch (gimple_call_internal_fn (stmt))
	  {
	  case IFN_GOMP_SIMD_LANE:
	    {
	      struct loop *loop = gimple_bb (stmt)->loop_father;
	      tree uid = gimple_call_arg (stmt, 0);
	      gcc_assert (TREE_CODE (uid) == SSA_NAME);
	      if (loop == NULL
		  || loop->simduid != SSA_NAME_VAR (uid))
		clobbers_memory = true;
	      break;
	    }
	  case IFN_MASK_LOAD:
	  case IFN_MASK_STORE:
	    break;
	  default:
	    clobbers_memory = true;
	    break;
	  }
      else
	clobbers_memory = true;
    }
  else if (stmt_code == GIMPLE_ASM
	   && (gimple_asm_volatile_p (as_a <gasm *> (stmt))
	       || gimple_vuse (stmt)))
    clobbers_memory = true;

  if (!gimple_vuse (stmt))
    return clobbers_memory;

  if (stmt_code == GIMPLE_ASSIGN)
    {
      tree base;
      op0 = gimple_assign_lhs (stmt);
      op1 = gimple_assign_rhs1 (stmt);

      if (DECL_P (op1)
	  || (REFERENCE_CLASS_P (op1)
	      && (base = get_base_address (op1))
	      && TREE_CODE (base) != SSA_NAME
	      && !is_gimple_min_invariant (base)))
	{
	  ref.ref = op1;
	  ref.is_read = true;
	  ref.is_conditional_in_stmt = false;
	  references->safe_push (ref);
	}
    }
  else if (stmt_code == GIMPLE_CALL)
    {
      unsigned i, n;
      tree ptr, type;
      unsigned int align;

      ref.is_read = false;
      if (gimple_call_internal_p (stmt))
	switch (gimple_call_internal_fn (stmt))
	  {
	  case IFN_MASK_LOAD:
	    if (gimple_call_lhs (stmt) == NULL_TREE)
	      break;
	    ref.is_read = true;
	    /* FALLTHRU */
	  case IFN_MASK_STORE:
	    ptr = build_int_cst (TREE_TYPE (gimple_call_arg (stmt, 1)), 0);
	    align = tree_to_shwi (gimple_call_arg (stmt, 1));
	    if (ref.is_read)
	      type = TREE_TYPE (gimple_call_lhs (stmt));
	    else
	      type = TREE_TYPE (gimple_call_arg (stmt, 3));
	    if (TYPE_ALIGN (type) != align)
	      type = build_aligned_type (type, align);
	    ref.is_conditional_in_stmt = true;
	    ref.ref = fold_build2 (MEM_REF, type, gimple_call_arg (stmt, 0),
				   ptr);
	    references->safe_push (ref);
	    return false;
	  default:
	    break;
	  }

      op0 = gimple_call_lhs (stmt);
      n = gimple_call_num_args (stmt);
      for (i = 0; i < n; i++)
	{
	  op1 = gimple_call_arg (stmt, i);

	  if (DECL_P (op1)
	      || (REFERENCE_CLASS_P (op1) && get_base_address (op1)))
	    {
	      ref.ref = op1;
	      ref.is_read = true;
	      ref.is_conditional_in_stmt = false;
	      references->safe_push (ref);
	    }
	}
    }
  else
    return clobbers_memory;

  if (op0
      && (DECL_P (op0)
	  || (REFERENCE_CLASS_P (op0) && get_base_address (op0))))
    {
      ref.ref = op0;
      ref.is_read = false;
      ref.is_conditional_in_stmt = false;
      references->safe_push (ref);
    }
  return clobbers_memory;
}


/* Returns true if the loop-nest has any data reference.  */

bool
loop_nest_has_data_refs (loop_p loop)
{
  basic_block *bbs = get_loop_body (loop);
  auto_vec<data_ref_loc, 3> references;

  for (unsigned i = 0; i < loop->num_nodes; i++)
    {
      basic_block bb = bbs[i];
      gimple_stmt_iterator bsi;

      for (bsi = gsi_start_bb (bb); !gsi_end_p (bsi); gsi_next (&bsi))
	{
	  gimple *stmt = gsi_stmt (bsi);
	  get_references_in_stmt (stmt, &references);
	  if (references.length ())
	    {
	      free (bbs);
	      return true;
	    }
	}
    }
  free (bbs);

  if (loop->inner)
    {
      loop = loop->inner;
      while (loop)
	{
	  if (loop_nest_has_data_refs (loop))
	    return true;
	  loop = loop->next;
	}
    }
  return false;
}

/* Stores the data references in STMT to DATAREFS.  If there is an unanalyzable
   reference, returns false, otherwise returns true.  NEST is the outermost
   loop of the loop nest in which the references should be analyzed.  */

bool
find_data_references_in_stmt (struct loop *nest, gimple *stmt,
			      vec<data_reference_p> *datarefs)
{
  unsigned i;
  auto_vec<data_ref_loc, 2> references;
  data_ref_loc *ref;
  bool ret = true;
  data_reference_p dr;

  if (get_references_in_stmt (stmt, &references))
    return false;

  FOR_EACH_VEC_ELT (references, i, ref)
    {
      dr = create_data_ref (nest, loop_containing_stmt (stmt), ref->ref,
			    stmt, ref->is_read, ref->is_conditional_in_stmt);
      gcc_assert (dr != NULL);
      datarefs->safe_push (dr);
    }

  return ret;
}

/* Stores the data references in STMT to DATAREFS.  If there is an
   unanalyzable reference, returns false, otherwise returns true.
   NEST is the outermost loop of the loop nest in which the references
   should be instantiated, LOOP is the loop in which the references
   should be analyzed.  */

bool
graphite_find_data_references_in_stmt (loop_p nest, loop_p loop, gimple *stmt,
				       vec<data_reference_p> *datarefs)
{
  unsigned i;
  auto_vec<data_ref_loc, 2> references;
  data_ref_loc *ref;
  bool ret = true;
  data_reference_p dr;

  if (get_references_in_stmt (stmt, &references))
    return false;

  FOR_EACH_VEC_ELT (references, i, ref)
    {
      dr = create_data_ref (nest, loop, ref->ref, stmt, ref->is_read,
			    ref->is_conditional_in_stmt);
      gcc_assert (dr != NULL);
      datarefs->safe_push (dr);
    }

  return ret;
}

/* Search the data references in LOOP, and record the information into
   DATAREFS.  Returns chrec_dont_know when failing to analyze a
   difficult case, returns NULL_TREE otherwise.  */

tree
find_data_references_in_bb (struct loop *loop, basic_block bb,
                            vec<data_reference_p> *datarefs)
{
  gimple_stmt_iterator bsi;

  for (bsi = gsi_start_bb (bb); !gsi_end_p (bsi); gsi_next (&bsi))
    {
      gimple *stmt = gsi_stmt (bsi);

      if (!find_data_references_in_stmt (loop, stmt, datarefs))
        {
          struct data_reference *res;
          res = XCNEW (struct data_reference);
          datarefs->safe_push (res);

          return chrec_dont_know;
        }
    }

  return NULL_TREE;
}

/* Search the data references in LOOP, and record the information into
   DATAREFS.  Returns chrec_dont_know when failing to analyze a
   difficult case, returns NULL_TREE otherwise.

   TODO: This function should be made smarter so that it can handle address
   arithmetic as if they were array accesses, etc.  */

tree
find_data_references_in_loop (struct loop *loop,
			      vec<data_reference_p> *datarefs)
{
  basic_block bb, *bbs;
  unsigned int i;

  bbs = get_loop_body_in_dom_order (loop);

  for (i = 0; i < loop->num_nodes; i++)
    {
      bb = bbs[i];

      if (find_data_references_in_bb (loop, bb, datarefs) == chrec_dont_know)
        {
          free (bbs);
          return chrec_dont_know;
        }
    }
  free (bbs);

  return NULL_TREE;
}

/* Return the alignment in bytes that DRB is guaranteed to have at all
   times.  */

unsigned int
dr_alignment (innermost_loop_behavior *drb)
{
  /* Get the alignment of BASE_ADDRESS + INIT.  */
  unsigned int alignment = drb->base_alignment;
  unsigned int misalignment = (drb->base_misalignment
			       + TREE_INT_CST_LOW (drb->init));
  if (misalignment != 0)
    alignment = MIN (alignment, misalignment & -misalignment);

  /* Cap it to the alignment of OFFSET.  */
  if (!integer_zerop (drb->offset))
    alignment = MIN (alignment, drb->offset_alignment);

  /* Cap it to the alignment of STEP.  */
  if (!integer_zerop (drb->step))
    alignment = MIN (alignment, drb->step_alignment);

  return alignment;
}

/* Recursive helper function.  */

static bool
find_loop_nest_1 (struct loop *loop, vec<loop_p> *loop_nest)
{
  /* Inner loops of the nest should not contain siblings.  Example:
     when there are two consecutive loops,

     | loop_0
     |   loop_1
     |     A[{0, +, 1}_1]
     |   endloop_1
     |   loop_2
     |     A[{0, +, 1}_2]
     |   endloop_2
     | endloop_0

     the dependence relation cannot be captured by the distance
     abstraction.  */
  if (loop->next)
    return false;

  loop_nest->safe_push (loop);
  if (loop->inner)
    return find_loop_nest_1 (loop->inner, loop_nest);
  return true;
}

/* Return false when the LOOP is not well nested.  Otherwise return
   true and insert in LOOP_NEST the loops of the nest.  LOOP_NEST will
   contain the loops from the outermost to the innermost, as they will
   appear in the classic distance vector.  */

bool
find_loop_nest (struct loop *loop, vec<loop_p> *loop_nest)
{
  loop_nest->safe_push (loop);
  if (loop->inner)
    return find_loop_nest_1 (loop->inner, loop_nest);
  return true;
}

/* Returns true when the data dependences have been computed, false otherwise.
   Given a loop nest LOOP, the following vectors are returned:
   DATAREFS is initialized to all the array elements contained in this loop,
   DEPENDENCE_RELATIONS contains the relations between the data references.
   Compute read-read and self relations if
   COMPUTE_SELF_AND_READ_READ_DEPENDENCES is TRUE.  */

bool
compute_data_dependences_for_loop (struct loop *loop,
				   bool compute_self_and_read_read_dependences,
				   vec<loop_p> *loop_nest,
				   vec<data_reference_p> *datarefs,
				   vec<ddr_p> *dependence_relations)
{
  bool res = true;

  memset (&dependence_stats, 0, sizeof (dependence_stats));

  /* If the loop nest is not well formed, or one of the data references
     is not computable, give up without spending time to compute other
     dependences.  */
  if (!loop
      || !find_loop_nest (loop, loop_nest)
      || find_data_references_in_loop (loop, datarefs) == chrec_dont_know
      || !compute_all_dependences (*datarefs, dependence_relations, *loop_nest,
				   compute_self_and_read_read_dependences))
    res = false;

  if (dump_file && (dump_flags & TDF_STATS))
    {
      fprintf (dump_file, "Dependence tester statistics:\n");

      fprintf (dump_file, "Number of dependence tests: %d\n",
	       dependence_stats.num_dependence_tests);
      fprintf (dump_file, "Number of dependence tests classified dependent: %d\n",
	       dependence_stats.num_dependence_dependent);
      fprintf (dump_file, "Number of dependence tests classified independent: %d\n",
	       dependence_stats.num_dependence_independent);
      fprintf (dump_file, "Number of undetermined dependence tests: %d\n",
	       dependence_stats.num_dependence_undetermined);

      fprintf (dump_file, "Number of subscript tests: %d\n",
	       dependence_stats.num_subscript_tests);
      fprintf (dump_file, "Number of undetermined subscript tests: %d\n",
	       dependence_stats.num_subscript_undetermined);
      fprintf (dump_file, "Number of same subscript function: %d\n",
	       dependence_stats.num_same_subscript_function);

      fprintf (dump_file, "Number of ziv tests: %d\n",
	       dependence_stats.num_ziv);
      fprintf (dump_file, "Number of ziv tests returning dependent: %d\n",
	       dependence_stats.num_ziv_dependent);
      fprintf (dump_file, "Number of ziv tests returning independent: %d\n",
	       dependence_stats.num_ziv_independent);
      fprintf (dump_file, "Number of ziv tests unimplemented: %d\n",
	       dependence_stats.num_ziv_unimplemented);

      fprintf (dump_file, "Number of siv tests: %d\n",
	       dependence_stats.num_siv);
      fprintf (dump_file, "Number of siv tests returning dependent: %d\n",
	       dependence_stats.num_siv_dependent);
      fprintf (dump_file, "Number of siv tests returning independent: %d\n",
	       dependence_stats.num_siv_independent);
      fprintf (dump_file, "Number of siv tests unimplemented: %d\n",
	       dependence_stats.num_siv_unimplemented);

      fprintf (dump_file, "Number of miv tests: %d\n",
	       dependence_stats.num_miv);
      fprintf (dump_file, "Number of miv tests returning dependent: %d\n",
	       dependence_stats.num_miv_dependent);
      fprintf (dump_file, "Number of miv tests returning independent: %d\n",
	       dependence_stats.num_miv_independent);
      fprintf (dump_file, "Number of miv tests unimplemented: %d\n",
	       dependence_stats.num_miv_unimplemented);
    }

  return res;
}

/* Free the memory used by a data dependence relation DDR.  */

void
free_dependence_relation (struct data_dependence_relation *ddr)
{
  if (ddr == NULL)
    return;

  if (DDR_SUBSCRIPTS (ddr).exists ())
    free_subscripts (DDR_SUBSCRIPTS (ddr));
  DDR_DIST_VECTS (ddr).release ();
  DDR_DIR_VECTS (ddr).release ();

  free (ddr);
}

/* Free the memory used by the data dependence relations from
   DEPENDENCE_RELATIONS.  */

void
free_dependence_relations (vec<ddr_p> dependence_relations)
{
  unsigned int i;
  struct data_dependence_relation *ddr;

  FOR_EACH_VEC_ELT (dependence_relations, i, ddr)
    if (ddr)
      free_dependence_relation (ddr);

  dependence_relations.release ();
}

/* Free the memory used by the data references from DATAREFS.  */

void
free_data_refs (vec<data_reference_p> datarefs)
{
  unsigned int i;
  struct data_reference *dr;

  FOR_EACH_VEC_ELT (datarefs, i, dr)
    free_data_ref (dr);
  datarefs.release ();
}
>->name, NULL); if (! gfc_compare_types (ts, fts) || (el->sym->result->attr.dimension != ns->entries->sym->result->attr.dimension) || (el->sym->result->attr.pointer != ns->entries->sym->result->attr.pointer)) break; else if (as && fas && ns->entries->sym->result != el->sym->result && gfc_compare_array_spec (as, fas) == 0) gfc_error ("Function %s at %L has entries with mismatched " "array specifications", ns->entries->sym->name, &ns->entries->sym->declared_at); /* The characteristics need to match and thus both need to have the same string length, i.e. both len=*, or both len=4. Having both len=<variable> is also possible, but difficult to check at compile time. */ else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl && (((ts->u.cl->length && !fts->u.cl->length) ||(!ts->u.cl->length && fts->u.cl->length)) || (ts->u.cl->length && ts->u.cl->length->expr_type != fts->u.cl->length->expr_type) || (ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT && mpz_cmp (ts->u.cl->length->value.integer, fts->u.cl->length->value.integer) != 0))) gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " "entries returning variables of different " "string lengths", ns->entries->sym->name, &ns->entries->sym->declared_at); } if (el == NULL) { sym = ns->entries->sym->result; /* All result types the same. */ proc->ts = *fts; if (sym->attr.dimension) gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); if (sym->attr.pointer) gfc_add_pointer (&proc->attr, NULL); } else { /* Otherwise the result will be passed through a union by reference. */ proc->attr.mixed_entry_master = 1; for (el = ns->entries; el; el = el->next) { sym = el->sym->result; if (sym->attr.dimension) { if (el == ns->entries) gfc_error ("FUNCTION result %s cannot be an array in " "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); else gfc_error ("ENTRY result %s cannot be an array in " "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); } else if (sym->attr.pointer) { if (el == ns->entries) gfc_error ("FUNCTION result %s cannot be a POINTER in " "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); else gfc_error ("ENTRY result %s cannot be a POINTER in " "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); } else { ts = &sym->ts; if (ts->type == BT_UNKNOWN) ts = gfc_get_default_type (sym->name, NULL); switch (ts->type) { case BT_INTEGER: if (ts->kind == gfc_default_integer_kind) sym = NULL; break; case BT_REAL: if (ts->kind == gfc_default_real_kind || ts->kind == gfc_default_double_kind) sym = NULL; break; case BT_COMPLEX: if (ts->kind == gfc_default_complex_kind) sym = NULL; break; case BT_LOGICAL: if (ts->kind == gfc_default_logical_kind) sym = NULL; break; case BT_UNKNOWN: /* We will issue error elsewhere. */ sym = NULL; break; default: break; } if (sym) { if (el == ns->entries) gfc_error ("FUNCTION result %s cannot be of type %s " "in FUNCTION %s at %L", sym->name, gfc_typename (ts), ns->entries->sym->name, &sym->declared_at); else gfc_error ("ENTRY result %s cannot be of type %s " "in FUNCTION %s at %L", sym->name, gfc_typename (ts), ns->entries->sym->name, &sym->declared_at); } } } } } proc->attr.access = ACCESS_PRIVATE; proc->attr.entry_master = 1; /* Merge all the entry point arguments. */ for (el = ns->entries; el; el = el->next) merge_argument_lists (proc, el->sym->formal); /* Check the master formal arguments for any that are not present in all entry points. */ for (el = ns->entries; el; el = el->next) check_argument_lists (proc, el->sym->formal); /* Use the master function for the function body. */ ns->proc_name = proc; /* Finalize the new symbols. */ gfc_commit_symbols (); /* Restore the original namespace. */ gfc_current_ns = old_ns; } /* Resolve common variables. */ static void resolve_common_vars (gfc_common_head *common_block, bool named_common) { gfc_symbol *csym = common_block->head; for (; csym; csym = csym->common_next) { /* gfc_add_in_common may have been called before, but the reported errors have been ignored to continue parsing. We do the checks again here. */ if (!csym->attr.use_assoc) { gfc_add_in_common (&csym->attr, csym->name, &common_block->where); gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L", &common_block->where); } if (csym->value || csym->attr.data) { if (!csym->ns->is_block_data) gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " "but only in BLOCK DATA initialization is " "allowed", csym->name, &csym->declared_at); else if (!named_common) gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " "in a blank COMMON but initialization is only " "allowed in named common blocks", csym->name, &csym->declared_at); } if (UNLIMITED_POLY (csym)) gfc_error_now ("%qs in cannot appear in COMMON at %L " "[F2008:C5100]", csym->name, &csym->declared_at); if (csym->ts.type != BT_DERIVED) continue; if (!(csym->ts.u.derived->attr.sequence || csym->ts.u.derived->attr.is_bind_c)) gfc_error_now ("Derived type variable %qs in COMMON at %L " "has neither the SEQUENCE nor the BIND(C) " "attribute", csym->name, &csym->declared_at); if (csym->ts.u.derived->attr.alloc_comp) gfc_error_now ("Derived type variable %qs in COMMON at %L " "has an ultimate component that is " "allocatable", csym->name, &csym->declared_at); if (gfc_has_default_initializer (csym->ts.u.derived)) gfc_error_now ("Derived type variable %qs in COMMON at %L " "may not have default initializer", csym->name, &csym->declared_at); if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer) gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at); } } /* Resolve common blocks. */ static void resolve_common_blocks (gfc_symtree *common_root) { gfc_symbol *sym; gfc_gsymbol * gsym; if (common_root == NULL) return; if (common_root->left) resolve_common_blocks (common_root->left); if (common_root->right) resolve_common_blocks (common_root->right); resolve_common_vars (common_root->n.common, true); /* The common name is a global name - in Fortran 2003 also if it has a C binding name, since Fortran 2008 only the C binding name is a global identifier. */ if (!common_root->n.common->binding_label || gfc_notification_std (GFC_STD_F2008)) { gsym = gfc_find_gsymbol (gfc_gsym_root, common_root->n.common->name); if (gsym && gfc_notification_std (GFC_STD_F2008) && gsym->type == GSYM_COMMON && ((common_root->n.common->binding_label && (!gsym->binding_label || strcmp (common_root->n.common->binding_label, gsym->binding_label) != 0)) || (!common_root->n.common->binding_label && gsym->binding_label))) { gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " "identifier and must thus have the same binding name " "as the same-named COMMON block at %L: %s vs %s", common_root->n.common->name, &common_root->n.common->where, &gsym->where, common_root->n.common->binding_label ? common_root->n.common->binding_label : "(blank)", gsym->binding_label ? gsym->binding_label : "(blank)"); return; } if (gsym && gsym->type != GSYM_COMMON && !common_root->n.common->binding_label) { gfc_error ("COMMON block %qs at %L uses the same global identifier " "as entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); return; } if (gsym && gsym->type != GSYM_COMMON) { gfc_error ("Fortran 2008: COMMON block %qs with binding label at " "%L sharing the identifier with global non-COMMON-block " "entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); return; } if (!gsym) { gsym = gfc_get_gsymbol (common_root->n.common->name, false); gsym->type = GSYM_COMMON; gsym->where = common_root->n.common->where; gsym->defined = 1; } gsym->used = 1; } if (common_root->n.common->binding_label) { gsym = gfc_find_gsymbol (gfc_gsym_root, common_root->n.common->binding_label); if (gsym && gsym->type != GSYM_COMMON) { gfc_error ("COMMON block at %L with binding label %qs uses the same " "global identifier as entity at %L", &common_root->n.common->where, common_root->n.common->binding_label, &gsym->where); return; } if (!gsym) { gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true); gsym->type = GSYM_COMMON; gsym->where = common_root->n.common->where; gsym->defined = 1; } gsym->used = 1; } gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); if (sym == NULL) return; if (sym->attr.flavor == FL_PARAMETER) gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", sym->name, &common_root->n.common->where, &sym->declared_at); if (sym->attr.external) gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute", sym->name, &common_root->n.common->where); if (sym->attr.intrinsic) gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); else if (sym->attr.result || gfc_is_function_return_value (sym, gfc_current_ns)) gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " "that is also a function result", sym->name, &common_root->n.common->where); else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL && sym->attr.proc != PROC_ST_FUNCTION) gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " "that is also a global procedure", sym->name, &common_root->n.common->where); } /* Resolve contained function types. Because contained functions can call one another, they have to be worked out before any of the contained procedures can be resolved. The good news is that if a function doesn't already have a type, the only way it can get one is through an IMPLICIT type or a RESULT variable, because by definition contained functions are contained namespace they're contained in, not in a sibling or parent namespace. */ static void resolve_contained_functions (gfc_namespace *ns) { gfc_namespace *child; gfc_entry_list *el; resolve_formal_arglists (ns); for (child = ns->contained; child; child = child->sibling) { /* Resolve alternate entry points first. */ resolve_entries (child); /* Then check function return types. */ resolve_contained_fntype (child->proc_name, child); for (el = child->entries; el; el = el->next) resolve_contained_fntype (el->sym, child); } } /* A Parameterized Derived Type constructor must contain values for the PDT KIND parameters or they must have a default initializer. Go through the constructor picking out the KIND expressions, storing them in 'param_list' and then call gfc_get_pdt_instance to obtain the PDT instance. */ static gfc_actual_arglist *param_list, *param_tail, *param; static bool get_pdt_spec_expr (gfc_component *c, gfc_expr *expr) { param = gfc_get_actual_arglist (); if (!param_list) param_list = param_tail = param; else { param_tail->next = param; param_tail = param_tail->next; } param_tail->name = c->name; if (expr) param_tail->expr = gfc_copy_expr (expr); else if (c->initializer) param_tail->expr = gfc_copy_expr (c->initializer); else { param_tail->spec_type = SPEC_ASSUMED; if (c->attr.pdt_kind) { gfc_error ("The KIND parameter %qs in the PDT constructor " "at %C has no value", param->name); return false; } } return true; } static bool get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, gfc_symbol *derived) { gfc_constructor *cons = NULL; gfc_component *comp; bool t = true; if (expr && expr->expr_type == EXPR_STRUCTURE) cons = gfc_constructor_first (expr->value.constructor); else if (constr) cons = *constr; gcc_assert (cons); comp = derived->components; for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { if (cons->expr && cons->expr->expr_type == EXPR_STRUCTURE && comp->ts.type == BT_DERIVED) { t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); if (!t) return t; } else if (comp->ts.type == BT_DERIVED) { t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived); if (!t) return t; } else if ((comp->attr.pdt_kind || comp->attr.pdt_len) && derived->attr.pdt_template) { t = get_pdt_spec_expr (comp, cons->expr); if (!t) return t; } } return t; } static bool resolve_fl_derived0 (gfc_symbol *sym); static bool resolve_fl_struct (gfc_symbol *sym); /* Resolve all of the elements of a structure constructor and make sure that the types are correct. The 'init' flag indicates that the given constructor is an initializer. */ static bool resolve_structure_cons (gfc_expr *expr, int init) { gfc_constructor *cons; gfc_component *comp; bool t; symbol_attribute a; t = true; if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) { if (expr->ts.u.derived->attr.flavor == FL_DERIVED) resolve_fl_derived0 (expr->ts.u.derived); else resolve_fl_struct (expr->ts.u.derived); /* If this is a Parameterized Derived Type template, find the instance corresponding to the PDT kind parameters. */ if (expr->ts.u.derived->attr.pdt_template) { param_list = NULL; t = get_pdt_constructor (expr, NULL, expr->ts.u.derived); if (!t) return t; gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL); expr->param_list = gfc_copy_actual_arglist (param_list); if (param_list) gfc_free_actual_arglist (param_list); if (!expr->ts.u.derived->attr.pdt_type) return false; } } cons = gfc_constructor_first (expr->value.constructor); /* A constructor may have references if it is the result of substituting a parameter variable. In this case we just pull out the component we want. */ if (expr->ref) comp = expr->ref->u.c.sym->components; else comp = expr->ts.u.derived->components; for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { int rank; if (!cons->expr) continue; /* Unions use an EXPR_NULL contrived expression to tell the translation phase to generate an initializer of the appropriate length. Ignore it here. */ if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL) continue; if (!gfc_resolve_expr (cons->expr)) { t = false; continue; } rank = comp->as ? comp->as->rank : 0; if (comp->ts.type == BT_CLASS && !comp->ts.u.derived->attr.unlimited_polymorphic && CLASS_DATA (comp)->as) rank = CLASS_DATA (comp)->as->rank; if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank && (comp->attr.allocatable || cons->expr->rank)) { gfc_error ("The rank of the element in the structure " "constructor at %L does not match that of the " "component (%d/%d)", &cons->expr->where, cons->expr->rank, rank); t = false; } /* If we don't have the right type, try to convert it. */ if (!comp->attr.proc_pointer && !gfc_compare_types (&cons->expr->ts, &comp->ts)) { if (strcmp (comp->name, "_extends") == 0) { /* Can afford to be brutal with the _extends initializer. The derived type can get lost because it is PRIVATE but it is not usage constrained by the standard. */ cons->expr->ts = comp->ts; } else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) { gfc_error ("The element in the structure constructor at %L, " "for pointer component %qs, is %s but should be %s", &cons->expr->where, comp->name, gfc_basic_typename (cons->expr->ts.type), gfc_basic_typename (comp->ts.type)); t = false; } else { bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); if (t) t = t2; } } /* For strings, the length of the constructor should be the same as the one of the structure, ensure this if the lengths are known at compile time and when we are dealing with PARAMETER or structure constructors. */ if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl && comp->ts.u.cl->length && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT && cons->expr->rank != 0 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, comp->ts.u.cl->length->value.integer) != 0) { if (cons->expr->expr_type == EXPR_VARIABLE && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) { /* Wrap the parameter in an array constructor (EXPR_ARRAY) to make use of the gfc_resolve_character_array_constructor machinery. The expression is later simplified away to an array of string literals. */ gfc_expr *para = cons->expr; cons->expr = gfc_get_expr (); cons->expr->ts = para->ts; cons->expr->where = para->where; cons->expr->expr_type = EXPR_ARRAY; cons->expr->rank = para->rank; cons->expr->shape = gfc_copy_shape (para->shape, para->rank); gfc_constructor_append_expr (&cons->expr->value.constructor, para, &cons->expr->where); } if (cons->expr->expr_type == EXPR_ARRAY) { /* Rely on the cleanup of the namespace to deal correctly with the old charlen. (There was a block here that attempted to remove the charlen but broke the chain in so doing.) */ cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); cons->expr->ts.u.cl->length_from_typespec = true; cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); gfc_resolve_character_array_constructor (cons->expr); } } if (cons->expr->expr_type == EXPR_NULL && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID || (comp->ts.type == BT_CLASS && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { t = false; gfc_error ("The NULL in the structure constructor at %L is " "being applied to component %qs, which is neither " "a POINTER nor ALLOCATABLE", &cons->expr->where, comp->name); } if (comp->attr.proc_pointer && comp->ts.interface) { /* Check procedure pointer interface. */ gfc_symbol *s2 = NULL; gfc_component *c2; const char *name; char err[200]; c2 = gfc_get_proc_ptr_comp (cons->expr); if (c2) { s2 = c2->ts.interface; name = c2->name; } else if (cons->expr->expr_type == EXPR_FUNCTION) { s2 = cons->expr->symtree->n.sym->result; name = cons->expr->symtree->n.sym->result->name; } else if (cons->expr->expr_type != EXPR_NULL) { s2 = cons->expr->symtree->n.sym; name = cons->expr->symtree->n.sym->name; } if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, err, sizeof (err), NULL, NULL)) { gfc_error_opt (0, "Interface mismatch for procedure-pointer " "component %qs in structure constructor at %L:" " %s", comp->name, &cons->expr->where, err); return false; } } if (!comp->attr.pointer || comp->attr.proc_pointer || cons->expr->expr_type == EXPR_NULL) continue; a = gfc_expr_attr (cons->expr); if (!a.pointer && !a.target) { t = false; gfc_error ("The element in the structure constructor at %L, " "for pointer component %qs should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); } if (init) { /* F08:C461. Additional checks for pointer initialization. */ if (a.allocatable) { t = false; gfc_error ("Pointer initialization target at %L " "must not be ALLOCATABLE", &cons->expr->where); } if (!a.save) { t = false; gfc_error ("Pointer initialization target at %L " "must have the SAVE attribute", &cons->expr->where); } } /* F2003, C1272 (3). */ bool impure = cons->expr->expr_type == EXPR_VARIABLE && (gfc_impure_variable (cons->expr->symtree->n.sym) || gfc_is_coindexed (cons->expr)); if (impure && gfc_pure (NULL)) { t = false; gfc_error ("Invalid expression in the structure constructor for " "pointer component %qs at %L in PURE procedure", comp->name, &cons->expr->where); } if (impure) gfc_unset_implicit_pure (NULL); } return t; } /****************** Expression name resolution ******************/ /* Returns 0 if a symbol was not declared with a type or attribute declaration statement, nonzero otherwise. */ static int was_declared (gfc_symbol *sym) { symbol_attribute a; a = sym->attr; if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) return 1; if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN || a.asynchronous || a.codimension) return 1; return 0; } /* Determine if a symbol is generic or not. */ static int generic_sym (gfc_symbol *sym) { gfc_symbol *s; if (sym->attr.generic || (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) return 1; if (was_declared (sym) || sym->ns->parent == NULL) return 0; gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); if (s != NULL) { if (s == sym) return 0; else return generic_sym (s); } return 0; } /* Determine if a symbol is specific or not. */ static int specific_sym (gfc_symbol *sym) { gfc_symbol *s; if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL || sym->attr.proc == PROC_ST_FUNCTION || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) || sym->attr.external) return 1; if (was_declared (sym) || sym->ns->parent == NULL) return 0; gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); return (s == NULL) ? 0 : specific_sym (s); } /* Figure out if the procedure is specific, generic or unknown. */ enum proc_type { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; static proc_type procedure_kind (gfc_symbol *sym) { if (generic_sym (sym)) return PTYPE_GENERIC; if (specific_sym (sym)) return PTYPE_SPECIFIC; return PTYPE_UNKNOWN; } /* Check references to assumed size arrays. The flag need_full_assumed_size is nonzero when matching actual arguments. */ static int need_full_assumed_size = 0; static bool check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) { if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) return false; /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. What should it be? */ if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) && (e->ref->u.ar.type == AR_FULL)) { gfc_error ("The upper bound in the last dimension must " "appear in the reference to the assumed size " "array %qs at %L", sym->name, &e->where); return true; } return false; } /* Look for bad assumed size array references in argument expressions of elemental and array valued intrinsic procedures. Since this is called from procedure resolution functions, it only recurses at operators. */ static bool resolve_assumed_size_actual (gfc_expr *e) { if (e == NULL) return false; switch (e->expr_type) { case EXPR_VARIABLE: if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) return true; break; case EXPR_OP: if (resolve_assumed_size_actual (e->value.op.op1) || resolve_assumed_size_actual (e->value.op.op2)) return true; break; default: break; } return false; } /* Check a generic procedure, passed as an actual argument, to see if there is a matching specific name. If none, it is an error, and if more than one, the reference is ambiguous. */ static int count_specific_procs (gfc_expr *e) { int n; gfc_interface *p; gfc_symbol *sym; n = 0; sym = e->symtree->n.sym; for (p = sym->generic; p; p = p->next) if (strcmp (sym->name, p->sym->name) == 0) { e->symtree = gfc_find_symtree (p->sym->ns->sym_root, sym->name); n++; } if (n > 1) gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, &e->where); if (n == 0) gfc_error ("GENERIC procedure %qs is not allowed as an actual " "argument at %L", sym->name, &e->where); return n; } /* See if a call to sym could possibly be a not allowed RECURSION because of a missing RECURSIVE declaration. This means that either sym is the current context itself, or sym is the parent of a contained procedure calling its non-RECURSIVE containing procedure. This also works if sym is an ENTRY. */ static bool is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) { gfc_symbol* proc_sym; gfc_symbol* context_proc; gfc_namespace* real_context; if (sym->attr.flavor == FL_PROGRAM || gfc_fl_struct (sym->attr.flavor)) return false; /* If we've got an ENTRY, find real procedure. */ if (sym->attr.entry && sym->ns->entries) proc_sym = sym->ns->entries->sym; else proc_sym = sym; /* If sym is RECURSIVE, all is well of course. */ if (proc_sym->attr.recursive || flag_recursive) return false; /* Find the context procedure's "real" symbol if it has entries. We look for a procedure symbol, so recurse on the parents if we don't find one (like in case of a BLOCK construct). */ for (real_context = context; ; real_context = real_context->parent) { /* We should find something, eventually! */ gcc_assert (real_context); context_proc = (real_context->entries ? real_context->entries->sym : real_context->proc_name); /* In some special cases, there may not be a proc_name, like for this invalid code: real(bad_kind()) function foo () ... when checking the call to bad_kind (). In these cases, we simply return here and assume that the call is ok. */ if (!context_proc) return false; if (context_proc->attr.flavor != FL_LABEL) break; } /* A call from sym's body to itself is recursion, of course. */ if (context_proc == proc_sym) return true; /* The same is true if context is a contained procedure and sym the containing one. */ if (context_proc->attr.contained) { gfc_symbol* parent_proc; gcc_assert (context->parent); parent_proc = (context->parent->entries ? context->parent->entries->sym : context->parent->proc_name); if (parent_proc == proc_sym) return true; } return false; } /* Resolve an intrinsic procedure: Set its function/subroutine attribute, its typespec and formal argument list. */ bool gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_intrinsic_sym* isym = NULL; const char* symstd; if (sym->formal) return true; /* Already resolved. */ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) return true; /* We already know this one is an intrinsic, so we don't call gfc_is_intrinsic for full checking but rather use gfc_find_function and gfc_find_subroutine directly to check whether it is a function or subroutine. */ if (sym->intmod_sym_id && sym->attr.subroutine) { gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); isym = gfc_intrinsic_subroutine_by_id (id); } else if (sym->intmod_sym_id) { gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); isym = gfc_intrinsic_function_by_id (id); } else if (!sym->attr.subroutine) isym = gfc_find_function (sym->name); if (isym && !sym->attr.subroutine) { if (sym->ts.type != BT_UNKNOWN && warn_surprising && !sym->attr.implicit_type) gfc_warning (OPT_Wsurprising, "Type specified for intrinsic function %qs at %L is" " ignored", sym->name, &sym->declared_at); if (!sym->attr.function && !gfc_add_function(&sym->attr, sym->name, loc)) return false; sym->ts = isym->ts; } else if (isym || (isym = gfc_find_subroutine (sym->name))) { if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) { gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" " specifier", sym->name, &sym->declared_at); return false; } if (!sym->attr.subroutine && !gfc_add_subroutine(&sym->attr, sym->name, loc)) return false; } else { gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, &sym->declared_at); return false; } gfc_copy_formal_args_intr (sym, isym, NULL); sym->attr.pure = isym->pure; sym->attr.elemental = isym->elemental; /* Check it is actually available in the standard settings. */ if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) { gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not " "available in the current standard settings but %s. Use " "an appropriate %<-std=*%> option or enable " "%<-fall-intrinsics%> in order to use it.", sym->name, &sym->declared_at, symstd); return false; } return true; } /* Resolve a procedure expression, like passing it to a called procedure or as RHS for a procedure pointer assignment. */ static bool resolve_procedure_expression (gfc_expr* expr) { gfc_symbol* sym; if (expr->expr_type != EXPR_VARIABLE) return true; gcc_assert (expr->symtree); sym = expr->symtree->n.sym; if (sym->attr.intrinsic) gfc_resolve_intrinsic (sym, &expr->where); if (sym->attr.flavor != FL_PROCEDURE || (sym->attr.function && sym->result == sym)) return true; /* A non-RECURSIVE procedure that is used as procedure expression within its own body is in danger of being called recursively. */ if (is_illegal_recursion (sym, gfc_current_ns)) gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" " itself recursively. Declare it RECURSIVE or use" " %<-frecursive%>", sym->name, &expr->where); return true; } /* Check that name is not a derived type. */ static bool is_dt_name (const char *name) { gfc_symbol *dt_list, *dt_first; dt_list = dt_first = gfc_derived_types; for (; dt_list; dt_list = dt_list->dt_next) { if (strcmp(dt_list->name, name) == 0) return true; if (dt_first == dt_list->dt_next) break; } return false; } /* Resolve an actual argument list. Most of the time, this is just resolving the expressions in the list. The exception is that we sometimes have to decide whether arguments that look like procedure arguments are really simple variable references. */ static bool resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, bool no_formal_args) { gfc_symbol *sym; gfc_symtree *parent_st; gfc_expr *e; gfc_component *comp; int save_need_full_assumed_size; bool return_value = false; bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; actual_arg = true; first_actual_arg = true; for (; arg; arg = arg->next) { e = arg->expr; if (e == NULL) { /* Check the label is a valid branching target. */ if (arg->label) { if (arg->label->defined == ST_LABEL_UNKNOWN) { gfc_error ("Label %d referenced at %L is never defined", arg->label->value, &arg->label->where); goto cleanup; } } first_actual_arg = false; continue; } if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.generic && no_formal_args && count_specific_procs (e) != 1) goto cleanup; if (e->ts.type != BT_PROCEDURE) { save_need_full_assumed_size = need_full_assumed_size; if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (!gfc_resolve_expr (e)) goto cleanup; need_full_assumed_size = save_need_full_assumed_size; goto argument_list; } /* See if the expression node should really be a variable reference. */ sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name)) { gfc_error ("Derived type %qs is used as an actual " "argument at %L", sym->name, &e->where); goto cleanup; } if (sym->attr.flavor == FL_PROCEDURE || sym->attr.intrinsic || sym->attr.external) { int actual_ok; /* If a procedure is not already determined to be something else check if it is intrinsic. */ if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) sym->attr.intrinsic = 1; if (sym->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Statement function %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine); if (sym->attr.intrinsic && actual_ok == 0) { gfc_error ("Intrinsic %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) { if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" " used as actual argument at %L", sym->name, &e->where)) goto cleanup; } if (sym->attr.elemental && !sym->attr.intrinsic) { gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " "allowed as an actual argument at %L", sym->name, &e->where); } /* Check if a generic interface has a specific procedure with the same name before emitting an error. */ if (sym->attr.generic && count_specific_procs (e) != 1) goto cleanup; /* Just in case a specific was found for the expression. */ sym = e->symtree->n.sym; /* If the symbol is the function that names the current (or parent) scope, then we really have a variable reference. */ if (gfc_is_function_return_value (sym, sym->ns)) goto got_variable; /* If all else fails, see if we have a specific intrinsic. */ if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) { gfc_intrinsic_sym *isym; isym = gfc_find_function (sym->name); if (isym == NULL || !isym->specific) { gfc_error ("Unable to find a specific INTRINSIC procedure " "for the reference %qs at %L", sym->name, &e->where); goto cleanup; } sym->ts = isym->ts; sym->attr.intrinsic = 1; sym->attr.function = 1; } if (!gfc_resolve_expr (e)) goto cleanup; goto argument_list; } /* See if the name is a module procedure in a parent unit. */ if (was_declared (sym) || sym->ns->parent == NULL) goto got_variable; if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) { gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); goto cleanup; } if (parent_st == NULL) goto got_variable; sym = parent_st->n.sym; e->symtree = parent_st; /* Point to the right thing. */ if (sym->attr.flavor == FL_PROCEDURE || sym->attr.intrinsic || sym->attr.external) { if (!gfc_resolve_expr (e)) goto cleanup; goto argument_list; } got_variable: e->expr_type = EXPR_VARIABLE; e->ts = sym->ts; if ((sym->as != NULL && sym->ts.type != BT_CLASS) || (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym)->as)) { e->rank = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as->rank : sym->as->rank; e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; e->ref->u.ar.as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as; } /* Expressions are assigned a default ts.type of BT_PROCEDURE in primary.c (match_actual_arg). If above code determines that it is a variable instead, it needs to be resolved as it was not done at the beginning of this function. */ save_need_full_assumed_size = need_full_assumed_size; if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (!gfc_resolve_expr (e)) goto cleanup; need_full_assumed_size = save_need_full_assumed_size; argument_list: /* Check argument list functions %VAL, %LOC and %REF. There is nothing to do for %REF. */ if (arg->name && arg->name[0] == '%') { if (strcmp ("%VAL", arg->name) == 0) { if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) { gfc_error ("By-value argument at %L is not of numeric " "type", &e->where); goto cleanup; } if (e->rank) { gfc_error ("By-value argument at %L cannot be an array or " "an array section", &e->where); goto cleanup; } /* Intrinsics are still PROC_UNKNOWN here. However, since same file external procedures are not resolvable in gfortran, it is a good deal easier to leave them to intrinsic.c. */ if (ptype != PROC_UNKNOWN && ptype != PROC_DUMMY && ptype != PROC_EXTERNAL && ptype != PROC_MODULE) { gfc_error ("By-value argument at %L is not allowed " "in this context", &e->where); goto cleanup; } } /* Statement functions have already been excluded above. */ else if (strcmp ("%LOC", arg->name) == 0 && e->ts.type == BT_PROCEDURE) { if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) { gfc_error ("Passing internal procedure at %L by location " "not allowed", &e->where); goto cleanup; } } } comp = gfc_get_proc_ptr_comp(e); if (e->expr_type == EXPR_VARIABLE && comp && comp->attr.elemental) { gfc_error ("ELEMENTAL procedure pointer component %qs is not " "allowed as an actual argument at %L", comp->name, &e->where); } /* Fortran 2008, C1237. */ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) && gfc_has_ultimate_pointer (e)) { gfc_error ("Coindexed actual argument at %L with ultimate pointer " "component", &e->where); goto cleanup; } first_actual_arg = false; } return_value = true; cleanup: actual_arg = actual_arg_sav; first_actual_arg = first_actual_arg_sav; return return_value; } /* Do the checks of the actual argument list that are specific to elemental procedures. If called with c == NULL, we have a function, otherwise if expr == NULL, we have a subroutine. */ static bool resolve_elemental_actual (gfc_expr *expr, gfc_code *c) { gfc_actual_arglist *arg0; gfc_actual_arglist *arg; gfc_symbol *esym = NULL; gfc_intrinsic_sym *isym = NULL; gfc_expr *e = NULL; gfc_intrinsic_arg *iformal = NULL; gfc_formal_arglist *eformal = NULL; bool formal_optional = false; bool set_by_optional = false; int i; int rank = 0; /* Is this an elemental procedure? */ if (expr && expr->value.function.actual != NULL) { if (expr->value.function.esym != NULL && expr->value.function.esym->attr.elemental) { arg0 = expr->value.function.actual; esym = expr->value.function.esym; } else if (expr->value.function.isym != NULL && expr->value.function.isym->elemental) { arg0 = expr->value.function.actual; isym = expr->value.function.isym; } else return true; } else if (c && c->ext.actual != NULL) { arg0 = c->ext.actual; if (c->resolved_sym) esym = c->resolved_sym; else esym = c->symtree->n.sym; gcc_assert (esym); if (!esym->attr.elemental) return true; } else return true; /* The rank of an elemental is the rank of its array argument(s). */ for (arg = arg0; arg; arg = arg->next) { if (arg->expr != NULL && arg->expr->rank != 0) { rank = arg->expr->rank; if (arg->expr->expr_type == EXPR_VARIABLE && arg->expr->symtree->n.sym->attr.optional) set_by_optional = true; /* Function specific; set the result rank and shape. */ if (expr) { expr->rank = rank; if (!expr->shape && arg->expr->shape) { expr->shape = gfc_get_shape (rank); for (i = 0; i < rank; i++) mpz_init_set (expr->shape[i], arg->expr->shape[i]); } } break; } } /* If it is an array, it shall not be supplied as an actual argument to an elemental procedure unless an array of the same rank is supplied as an actual argument corresponding to a nonoptional dummy argument of that elemental procedure(12.4.1.5). */ formal_optional = false; if (isym) iformal = isym->formal; else eformal = esym->formal; for (arg = arg0; arg; arg = arg->next) { if (eformal) { if (eformal->sym && eformal->sym->attr.optional) formal_optional = true; eformal = eformal->next; } else if (isym && iformal) { if (iformal->optional) formal_optional = true; iformal = iformal->next; } else if (isym) formal_optional = true; if (pedantic && arg->expr != NULL && arg->expr->expr_type == EXPR_VARIABLE && arg->expr->symtree->n.sym->attr.optional && formal_optional && arg->expr->rank && (set_by_optional || arg->expr->rank != rank) && !(isym && isym->id == GFC_ISYM_CONVERSION)) { gfc_warning (OPT_Wpedantic, "%qs at %L is an array and OPTIONAL; IF IT IS " "MISSING, it cannot be the actual argument of an " "ELEMENTAL procedure unless there is a non-optional " "argument with the same rank (12.4.1.5)", arg->expr->symtree->n.sym->name, &arg->expr->where); } } for (arg = arg0; arg; arg = arg->next) { if (arg->expr == NULL || arg->expr->rank == 0) continue; /* Being elemental, the last upper bound of an assumed size array argument must be present. */ if (resolve_assumed_size_actual (arg->expr)) return false; /* Elemental procedure's array actual arguments must conform. */ if (e != NULL) { if (!gfc_check_conformance (arg->expr, e, "elemental procedure")) return false; } else e = arg->expr; } /* INTENT(OUT) is only allowed for subroutines; if any actual argument is an array, the intent inout/out variable needs to be also an array. */ if (rank > 0 && esym && expr == NULL) for (eformal = esym->formal, arg = arg0; arg && eformal; arg = arg->next, eformal = eformal->next) if ((eformal->sym->attr.intent == INTENT_OUT || eformal->sym->attr.intent == INTENT_INOUT) && arg->expr && arg->expr->rank == 0) { gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " "ELEMENTAL subroutine %qs is a scalar, but another " "actual argument is an array", &arg->expr->where, (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" : "INOUT", eformal->sym->name, esym->name); return false; } return true; } /* This function does the checking of references to global procedures as defined in sections 18.1 and 14.1, respectively, of the Fortran 77 and 95 standards. It checks for a gsymbol for the name, making one if it does not already exist. If it already exists, then the reference being resolved must correspond to the type of gsymbol. Otherwise, the new symbol is equipped with the attributes of the reference. The corresponding code that is called in creating global entities is parse.c. In addition, for all but -std=legacy, the gsymbols are used to check the interfaces of external procedures from the same file. The namespace of the gsymbol is resolved and then, once this is done the interface is checked. */ static bool not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) { if (!gsym_ns->proc_name->attr.recursive) return true; if (sym->ns == gsym_ns) return false; if (sym->ns->parent && sym->ns->parent == gsym_ns) return false; return true; } static bool not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) { if (gsym_ns->entries) { gfc_entry_list *entry = gsym_ns->entries; for (; entry; entry = entry->next) { if (strcmp (sym->name, entry->sym->name) == 0) { if (strcmp (gsym_ns->proc_name->name, sym->ns->proc_name->name) == 0) return false; if (sym->ns->parent && strcmp (gsym_ns->proc_name->name, sym->ns->parent->proc_name->name) == 0) return false; } } } return true; } /* Check for the requirement of an explicit interface. F08:12.4.2.2. */ bool gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) { gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); for ( ; arg; arg = arg->next) { if (!arg->sym) continue; if (arg->sym->attr.allocatable) /* (2a) */ { strncpy (errmsg, _("allocatable argument"), err_len); return true; } else if (arg->sym->attr.asynchronous) { strncpy (errmsg, _("asynchronous argument"), err_len); return true; } else if (arg->sym->attr.optional) { strncpy (errmsg, _("optional argument"), err_len); return true; } else if (arg->sym->attr.pointer) { strncpy (errmsg, _("pointer argument"), err_len); return true; } else if (arg->sym->attr.target) { strncpy (errmsg, _("target argument"), err_len); return true; } else if (arg->sym->attr.value) { strncpy (errmsg, _("value argument"), err_len); return true; } else if (arg->sym->attr.volatile_) { strncpy (errmsg, _("volatile argument"), err_len); return true; } else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ { strncpy (errmsg, _("assumed-shape argument"), err_len); return true; } else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ { strncpy (errmsg, _("assumed-rank argument"), err_len); return true; } else if (arg->sym->attr.codimension) /* (2c) */ { strncpy (errmsg, _("coarray argument"), err_len); return true; } else if (false) /* (2d) TODO: parametrized derived type */ { strncpy (errmsg, _("parametrized derived type argument"), err_len); return true; } else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ { strncpy (errmsg, _("polymorphic argument"), err_len); return true; } else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) { strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len); return true; } else if (arg->sym->ts.type == BT_ASSUMED) { /* As assumed-type is unlimited polymorphic (cf. above). See also TS 29113, Note 6.1. */ strncpy (errmsg, _("assumed-type argument"), err_len); return true; } } if (sym->attr.function) { gfc_symbol *res = sym->result ? sym->result : sym; if (res->attr.dimension) /* (3a) */ { strncpy (errmsg, _("array result"), err_len); return true; } else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ { strncpy (errmsg, _("pointer or allocatable result"), err_len); return true; } else if (res->ts.type == BT_CHARACTER && res->ts.u.cl && res->ts.u.cl->length && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ { strncpy (errmsg, _("result with non-constant character length"), err_len); return true; } } if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ { strncpy (errmsg, _("elemental procedure"), err_len); return true; } else if (sym->attr.is_bind_c) /* (5) */ { strncpy (errmsg, _("bind(c) procedure"), err_len); return true; } return false; } static void resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) { gfc_gsymbol * gsym; gfc_namespace *ns; enum gfc_symbol_type type; char reason[200]; type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, sym->binding_label != NULL); if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) gfc_global_used (gsym, where); if ((sym->attr.if_source == IFSRC_UNKNOWN || sym->attr.if_source == IFSRC_IFBODY) && gsym->type != GSYM_UNKNOWN && !gsym->binding_label && gsym->ns && gsym->ns->proc_name && not_in_recursive (sym, gsym->ns) && not_entry_self_reference (sym, gsym->ns)) { gfc_symbol *def_sym; def_sym = gsym->ns->proc_name; if (gsym->ns->resolved != -1) { /* Resolve the gsymbol namespace if needed. */ if (!gsym->ns->resolved) { gfc_symbol *old_dt_list; /* Stash away derived types so that the backend_decls do not get mixed up. */ old_dt_list = gfc_derived_types; gfc_derived_types = NULL; gfc_resolve (gsym->ns); /* Store the new derived types with the global namespace. */ if (gfc_derived_types) gsym->ns->derived_types = gfc_derived_types; /* Restore the derived types of this namespace. */ gfc_derived_types = old_dt_list; } /* Make sure that translation for the gsymbol occurs before the procedure currently being resolved. */ ns = gfc_global_ns_list; for (; ns && ns != gsym->ns; ns = ns->sibling) { if (ns->sibling == gsym->ns) { ns->sibling = gsym->ns->sibling; gsym->ns->sibling = gfc_global_ns_list; gfc_global_ns_list = gsym->ns; break; } } /* This can happen if a binding name has been specified. */ if (gsym->binding_label && gsym->sym_name != def_sym->name) gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym); if (def_sym->attr.entry_master || def_sym->attr.entry) { gfc_entry_list *entry; for (entry = gsym->ns->entries; entry; entry = entry->next) if (strcmp (entry->sym->name, sym->name) == 0) { def_sym = entry->sym; break; } } } if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) { gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&def_sym->ts)); goto done; } if (sym->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) { gfc_error ("Explicit interface required for %qs at %L: %s", sym->name, &sym->declared_at, reason); goto done; } if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) /* Turn erros into warnings with -std=gnu and -std=legacy. */ gfc_errors_to_warnings (true); if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, reason, sizeof(reason), NULL, NULL)) { gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:" " %s", sym->name, &sym->declared_at, reason); goto done; } } done: gfc_errors_to_warnings (false); if (gsym->type == GSYM_UNKNOWN) { gsym->type = type; gsym->where = *where; } gsym->used = 1; } /************* Function resolution *************/ /* Resolve a function call known to be generic. Section 14.1.2.4.1. */ static match resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) { gfc_symbol *s; if (sym->attr.generic) { s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); if (s != NULL) { expr->value.function.name = s->name; expr->value.function.esym = s; if (s->ts.type != BT_UNKNOWN) expr->ts = s->ts; else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) expr->ts = s->result->ts; if (s->as != NULL) expr->rank = s->as->rank; else if (s->result != NULL && s->result->as != NULL) expr->rank = s->result->as->rank; gfc_set_sym_referenced (expr->value.function.esym); return MATCH_YES; } /* TODO: Need to search for elemental references in generic interface. */ } if (sym->attr.intrinsic) return gfc_intrinsic_func_interface (expr, 0); return MATCH_NO; } static bool resolve_generic_f (gfc_expr *expr) { gfc_symbol *sym; match m; gfc_interface *intr = NULL; sym = expr->symtree->n.sym; for (;;) { m = resolve_generic_f0 (expr, sym); if (m == MATCH_YES) return true; else if (m == MATCH_ERROR) return false; generic: if (!intr) for (intr = sym->generic; intr; intr = intr->next) if (gfc_fl_struct (intr->sym->attr.flavor)) break; if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); if (sym == NULL) break; if (!generic_sym (sym)) goto generic; } /* Last ditch attempt. See if the reference is to an intrinsic that possesses a matching interface. 14.1.2.4 */ if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) { if (gfc_init_expr_flag) gfc_error ("Function %qs in initialization expression at %L " "must be an intrinsic function", expr->symtree->n.sym->name, &expr->where); else gfc_error ("There is no specific function for the generic %qs " "at %L", expr->symtree->n.sym->name, &expr->where); return false; } if (intr) { if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL, false)) return false; if (!gfc_use_derived (expr->ts.u.derived)) return false; return resolve_structure_cons (expr, 0); } m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) return true; if (m == MATCH_NO) gfc_error ("Generic function %qs at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, &expr->where); return false; } /* Resolve a function call known to be specific. */ static match resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) { match m; if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) { if (sym->attr.dummy) { sym->attr.proc = PROC_DUMMY; goto found; } sym->attr.proc = PROC_EXTERNAL; goto found; } if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_ST_FUNCTION || sym->attr.proc == PROC_INTERNAL) goto found; if (sym->attr.intrinsic) { m = gfc_intrinsic_func_interface (expr, 1); if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &expr->where); return MATCH_ERROR; } return MATCH_NO; found: gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); if (sym->result) expr->ts = sym->result->ts; else expr->ts = sym->ts; expr->value.function.name = sym->name; expr->value.function.esym = sym; /* Prevent crash when sym->ts.u.derived->components is not set due to previous error(s). */ if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)) return MATCH_ERROR; if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) expr->rank = CLASS_DATA (sym)->as->rank; else if (sym->as != NULL) expr->rank = sym->as->rank; return MATCH_YES; } static bool resolve_specific_f (gfc_expr *expr) { gfc_symbol *sym; match m; sym = expr->symtree->n.sym; for (;;) { m = resolve_specific_f0 (sym, expr); if (m == MATCH_YES) return true; if (m == MATCH_ERROR) return false; if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); if (sym == NULL) break; } gfc_error ("Unable to resolve the specific function %qs at %L", expr->symtree->n.sym->name, &expr->where); return true; } /* Recursively append candidate SYM to CANDIDATES. Store the number of candidates in CANDIDATES_LEN. */ static void lookup_function_fuzzy_find_candidates (gfc_symtree *sym, char **&candidates, size_t &candidates_len) { gfc_symtree *p; if (sym == NULL) return; if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external) && sym->n.sym->attr.flavor == FL_PROCEDURE) vec_push (candidates, candidates_len, sym->name); p = sym->left; if (p) lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); p = sym->right; if (p) lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); } /* Lookup function FN fuzzily, taking names in SYMROOT into account. */ const char* gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot) { char **candidates = NULL; size_t candidates_len = 0; lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len); return gfc_closest_fuzzy_match (fn, candidates); } /* Resolve a procedure call not known to be generic nor specific. */ static bool resolve_unknown_f (gfc_expr *expr) { gfc_symbol *sym; gfc_typespec *ts; sym = expr->symtree->n.sym; if (sym->attr.dummy) { sym->attr.proc = PROC_DUMMY; expr->value.function.name = sym->name; goto set_type; } /* See if we have an intrinsic function reference. */ if (gfc_is_intrinsic (sym, 0, expr->where)) { if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) return true; return false; } /* The reference is to an external name. */ sym->attr.proc = PROC_EXTERNAL; expr->value.function.name = sym->name; expr->value.function.esym = expr->symtree->n.sym; if (sym->as != NULL) expr->rank = sym->as->rank; /* Type of the expression is either the type of the symbol or the default type of the symbol. */ set_type: gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); if (sym->ts.type != BT_UNKNOWN) expr->ts = sym->ts; else { ts = gfc_get_default_type (sym->name, sym->ns); if (ts->type == BT_UNKNOWN) { const char *guessed = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); if (guessed) gfc_error ("Function %qs at %L has no IMPLICIT type" "; did you mean %qs?", sym->name, &expr->where, guessed); else gfc_error ("Function %qs at %L has no IMPLICIT type", sym->name, &expr->where); return false; } else expr->ts = *ts; } return true; } /* Return true, if the symbol is an external procedure. */ static bool is_external_proc (gfc_symbol *sym) { if (!sym->attr.dummy && !sym->attr.contained && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) && sym->attr.proc != PROC_ST_FUNCTION && !sym->attr.proc_pointer && !sym->attr.use_assoc && sym->name) return true; return false; } /* Figure out if a function reference is pure or not. Also set the name of the function for a potential error message. Return nonzero if the function is PURE, zero if not. */ static int pure_stmt_function (gfc_expr *, gfc_symbol *); int gfc_pure_function (gfc_expr *e, const char **name) { int pure; gfc_component *comp; *name = NULL; if (e->symtree != NULL && e->symtree->n.sym != NULL && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) return pure_stmt_function (e, e->symtree->n.sym); comp = gfc_get_proc_ptr_comp (e); if (comp) { pure = gfc_pure (comp->ts.interface); *name = comp->name; } else if (e->value.function.esym) { pure = gfc_pure (e->value.function.esym); *name = e->value.function.esym->name; } else if (e->value.function.isym) { pure = e->value.function.isym->pure || e->value.function.isym->elemental; *name = e->value.function.isym->name; } else { /* Implicit functions are not pure. */ pure = 0; *name = e->value.function.name; } return pure; } /* Check if the expression is a reference to an implicitly pure function. */ int gfc_implicit_pure_function (gfc_expr *e) { gfc_component *comp = gfc_get_proc_ptr_comp (e); if (comp) return gfc_implicit_pure (comp->ts.interface); else if (e->value.function.esym) return gfc_implicit_pure (e->value.function.esym); else return 0; } static bool impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { const char *name; /* Don't bother recursing into other statement functions since they will be checked individually for purity. */ if (e->expr_type != EXPR_FUNCTION || !e->symtree || e->symtree->n.sym == sym || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) return false; return gfc_pure_function (e, &name) ? false : true; } static int pure_stmt_function (gfc_expr *e, gfc_symbol *sym) { return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1; } /* Check if an impure function is allowed in the current context. */ static bool check_pure_function (gfc_expr *e) { const char *name = NULL; if (!gfc_pure_function (e, &name) && name) { if (forall_flag) { gfc_error ("Reference to impure function %qs at %L inside a " "FORALL %s", name, &e->where, forall_flag == 2 ? "mask" : "block"); return false; } else if (gfc_do_concurrent_flag) { gfc_error ("Reference to impure function %qs at %L inside a " "DO CONCURRENT %s", name, &e->where, gfc_do_concurrent_flag == 2 ? "mask" : "block"); return false; } else if (gfc_pure (NULL)) { gfc_error ("Reference to impure function %qs at %L " "within a PURE procedure", name, &e->where); return false; } if (!gfc_implicit_pure_function (e)) gfc_unset_implicit_pure (NULL); } return true; } /* Update current procedure's array_outer_dependency flag, considering a call to procedure SYM. */ static void update_current_proc_array_outer_dependency (gfc_symbol *sym) { /* Check to see if this is a sibling function that has not yet been resolved. */ gfc_namespace *sibling = gfc_current_ns->sibling; for (; sibling; sibling = sibling->sibling) { if (sibling->proc_name == sym) { gfc_resolve (sibling); break; } } /* If SYM has references to outer arrays, so has the procedure calling SYM. If SYM is a procedure pointer, we can assume the worst. */ if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer) && gfc_current_ns->proc_name) gfc_current_ns->proc_name->attr.array_outer_dependency = 1; } /* Resolve a function call, which means resolving the arguments, then figuring out which entity the name refers to. */ static bool resolve_function (gfc_expr *expr) { gfc_actual_arglist *arg; gfc_symbol *sym; bool t; int temp; procedure_type p = PROC_INTRINSIC; bool no_formal_args; sym = NULL; if (expr->symtree) sym = expr->symtree->n.sym; /* If this is a procedure pointer component, it has already been resolved. */ if (gfc_is_proc_ptr_comp (expr)) return true; /* Avoid re-resolving the arguments of caf_get, which can lead to inserting another caf_get. */ if (sym && sym->attr.intrinsic && (sym->intmod_sym_id == GFC_ISYM_CAF_GET || sym->intmod_sym_id == GFC_ISYM_CAF_SEND)) return true; if (sym && sym->attr.intrinsic && !gfc_resolve_intrinsic (sym, &expr->where)) return false; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { gfc_error ("%qs at %L is not a function", sym->name, &expr->where); return false; } /* If this is a deferred TBP with an abstract interface (which may of course be referenced), expr->value.function.esym will be set. */ if (sym && sym->attr.abstract && !expr->value.function.esym) { gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", sym->name, &expr->where); return false; } /* If this is a deferred TBP with an abstract interface, its result cannot be an assumed length character (F2003: C418). */ if (sym && sym->attr.abstract && sym->attr.function && sym->result->ts.u.cl && sym->result->ts.u.cl->length == NULL && !sym->result->ts.deferred) { gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed " "character length result (F2008: C418)", sym->name, &sym->declared_at); return false; } /* Switch off assumed size checking and do this again for certain kinds of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; if (expr->symtree && expr->symtree->n.sym) p = expr->symtree->n.sym->attr.proc; if (expr->value.function.isym && expr->value.function.isym->inquiry) inquiry_argument = true; no_formal_args = sym && is_external_proc (sym) && gfc_sym_get_dummy_args (sym) == NULL; if (!resolve_actual_arglist (expr->value.function.actual, p, no_formal_args)) { inquiry_argument = false; return false; } inquiry_argument = false; /* Resume assumed_size checking. */ need_full_assumed_size--; /* If the procedure is external, check for usage. */ if (sym && is_external_proc (sym)) resolve_global_procedure (sym, &expr->where, 0); if (sym && sym->ts.type == BT_CHARACTER && sym->ts.u.cl && sym->ts.u.cl->length == NULL && !sym->attr.dummy && !sym->ts.deferred && expr->value.function.esym == NULL && !sym->attr.contained) { /* Internal procedures are taken care of in resolve_contained_fntype. */ gfc_error ("Function %qs is declared CHARACTER(*) and cannot " "be used at %L since it is not a dummy argument", sym->name, &expr->where); return false; } /* See if function is already resolved. */ if (expr->value.function.name != NULL || expr->value.function.isym != NULL) { if (expr->ts.type == BT_UNKNOWN) expr->ts = sym->ts; t = true; } else { /* Apply the rules of section 14.1.2. */ switch (procedure_kind (sym)) { case PTYPE_GENERIC: t = resolve_generic_f (expr); break; case PTYPE_SPECIFIC: t = resolve_specific_f (expr); break; case PTYPE_UNKNOWN: t = resolve_unknown_f (expr); break; default: gfc_internal_error ("resolve_function(): bad function type"); } } /* If the expression is still a function (it might have simplified), then we check to see if we are calling an elemental function. */ if (expr->expr_type != EXPR_FUNCTION) return t; /* Walk the argument list looking for invalid BOZ. */ for (arg = expr->value.function.actual; arg; arg = arg->next) if (arg->expr && arg->expr->ts.type == BT_BOZ) { gfc_error ("A BOZ literal constant at %L cannot appear as an " "actual argument in a function reference", &arg->expr->where); return false; } temp = need_full_assumed_size; need_full_assumed_size = 0; if (!resolve_elemental_actual (expr, NULL)) return false; if (omp_workshare_flag && expr->value.function.esym && ! gfc_elemental (expr->value.function.esym)) { gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " "in WORKSHARE construct", expr->value.function.esym->name, &expr->where); t = false; } #define GENERIC_ID expr->value.function.isym->id else if (expr->value.function.actual != NULL && expr->value.function.isym != NULL && GENERIC_ID != GFC_ISYM_LBOUND && GENERIC_ID != GFC_ISYM_LCOBOUND && GENERIC_ID != GFC_ISYM_UCOBOUND && GENERIC_ID != GFC_ISYM_LEN && GENERIC_ID != GFC_ISYM_LOC && GENERIC_ID != GFC_ISYM_C_LOC && GENERIC_ID != GFC_ISYM_PRESENT) { /* Array intrinsics must also have the last upper bound of an assumed size array argument. UBOUND and SIZE have to be excluded from the check if the second argument is anything than a constant. */ for (arg = expr->value.function.actual; arg; arg = arg->next) { if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) && arg == expr->value.function.actual && arg->next != NULL && arg->next->expr) { if (arg->next->expr->expr_type != EXPR_CONSTANT) break; if (arg->next->name && strcmp (arg->next->name, "kind") == 0) break; if ((int)mpz_get_si (arg->next->expr->value.integer) < arg->expr->rank) break; } if (arg->expr != NULL && arg->expr->rank > 0 && resolve_assumed_size_actual (arg->expr)) return false; } } #undef GENERIC_ID need_full_assumed_size = temp; if (!check_pure_function(expr)) t = false; /* Functions without the RECURSIVE attribution are not allowed to * call themselves. */ if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) { gfc_symbol *esym; esym = expr->value.function.esym; if (is_illegal_recursion (esym, gfc_current_ns)) { if (esym->attr.entry && esym->ns->entries) gfc_error ("ENTRY %qs at %L cannot be called recursively, as" " function %qs is not RECURSIVE", esym->name, &expr->where, esym->ns->entries->sym->name); else gfc_error ("Function %qs at %L cannot be called recursively, as it" " is not RECURSIVE", esym->name, &expr->where); t = false; } } /* Character lengths of use associated functions may contains references to symbols not referenced from the current program unit otherwise. Make sure those symbols are marked as referenced. */ if (expr->ts.type == BT_CHARACTER && expr->value.function.esym && expr->value.function.esym->attr.use_assoc) { gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); } /* Make sure that the expression has a typespec that works. */ if (expr->ts.type == BT_UNKNOWN) { if (expr->symtree->n.sym->result && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN && !expr->symtree->n.sym->result->attr.proc_pointer) expr->ts = expr->symtree->n.sym->result->ts; } if (!expr->ref && !expr->value.function.isym) { if (expr->value.function.esym) update_current_proc_array_outer_dependency (expr->value.function.esym); else update_current_proc_array_outer_dependency (sym); } else if (expr->ref) /* typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; return t; } /************* Subroutine resolution *************/ static bool pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) { if (gfc_pure (sym)) return true; if (forall_flag) { gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", name, loc); return false; } else if (gfc_do_concurrent_flag) { gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " "PURE", name, loc); return false; } else if (gfc_pure (NULL)) { gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); return false; } gfc_unset_implicit_pure (NULL); return true; } static match resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) { gfc_symbol *s; if (sym->attr.generic) { s = gfc_search_interface (sym->generic, 1, &c->ext.actual); if (s != NULL) { c->resolved_sym = s; if (!pure_subroutine (s, s->name, &c->loc)) return MATCH_ERROR; return MATCH_YES; } /* TODO: Need to search for elemental references in generic interface. */ } if (sym->attr.intrinsic) return gfc_intrinsic_sub_interface (c, 0); return MATCH_NO; } static bool resolve_generic_s (gfc_code *c) { gfc_symbol *sym; match m; sym = c->symtree->n.sym; for (;;) { m = resolve_generic_s0 (c, sym); if (m == MATCH_YES) return true; else if (m == MATCH_ERROR) return false; generic: if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); if (sym == NULL) break; if (!generic_sym (sym)) goto generic; } /* Last ditch attempt. See if the reference is to an intrinsic that possesses a matching interface. 14.1.2.4 */ sym = c->symtree->n.sym; if (!gfc_is_intrinsic (sym, 1, c->loc)) { gfc_error ("There is no specific subroutine for the generic %qs at %L", sym->name, &c->loc); return false; } m = gfc_intrinsic_sub_interface (c, 0); if (m == MATCH_YES) return true; if (m == MATCH_NO) gfc_error ("Generic subroutine %qs at %L is not consistent with an " "intrinsic subroutine interface", sym->name, &c->loc); return false; } /* Resolve a subroutine call known to be specific. */ static match resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) { match m; if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) { if (sym->attr.dummy) { sym->attr.proc = PROC_DUMMY; goto found; } sym->attr.proc = PROC_EXTERNAL; goto found; } if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL) goto found; if (sym->attr.intrinsic) { m = gfc_intrinsic_sub_interface (c, 1); if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &c->loc); return MATCH_ERROR; } return MATCH_NO; found: gfc_procedure_use (sym, &c->ext.actual, &c->loc); c->resolved_sym = sym; if (!pure_subroutine (sym, sym->name, &c->loc)) return MATCH_ERROR; return MATCH_YES; } static bool resolve_specific_s (gfc_code *c) { gfc_symbol *sym; match m; sym = c->symtree->n.sym; for (;;) { m = resolve_specific_s0 (c, sym); if (m == MATCH_YES) return true; if (m == MATCH_ERROR) return false; if (sym->ns->parent == NULL) break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); if (sym == NULL) break; } sym = c->symtree->n.sym; gfc_error ("Unable to resolve the specific subroutine %qs at %L", sym->name, &c->loc); return false; } /* Resolve a subroutine call not known to be generic nor specific. */ static bool resolve_unknown_s (gfc_code *c) { gfc_symbol *sym; sym = c->symtree->n.sym; if (sym->attr.dummy) { sym->attr.proc = PROC_DUMMY; goto found; } /* See if we have an intrinsic function reference. */ if (gfc_is_intrinsic (sym, 1, c->loc)) { if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) return true; return false; } /* The reference is to an external name. */ found: gfc_procedure_use (sym, &c->ext.actual, &c->loc); c->resolved_sym = sym; return pure_subroutine (sym, sym->name, &c->loc); } /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ static bool resolve_call (gfc_code *c) { bool t; procedure_type ptype = PROC_INTRINSIC; gfc_symbol *csym, *sym; bool no_formal_args; csym = c->symtree ? c->symtree->n.sym : NULL; if (csym && csym->ts.type != BT_UNKNOWN) { gfc_error ("%qs at %L has a type, which is not consistent with " "the CALL at %L", csym->name, &csym->declared_at, &c->loc); return false; } if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) { gfc_symtree *st; gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); sym = st ? st->n.sym : NULL; if (sym && csym != sym && sym->ns == gfc_current_ns && sym->attr.flavor == FL_PROCEDURE && sym->attr.contained) { sym->refs++; if (csym->attr.generic) c->symtree->n.sym = sym; else c->symtree = st; csym = c->symtree->n.sym; } } /* If this ia a deferred TBP, c->expr1 will be set. */ if (!c->expr1 && csym) { if (csym->attr.abstract) { gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", csym->name, &c->loc); return false; } /* Subroutines without the RECURSIVE attribution are not allowed to call themselves. */ if (is_illegal_recursion (csym, gfc_current_ns)) { if (csym->attr.entry && csym->ns->entries) gfc_error ("ENTRY %qs at %L cannot be called recursively, " "as subroutine %qs is not RECURSIVE", csym->name, &c->loc, csym->ns->entries->sym->name); else gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " "as it is not RECURSIVE", csym->name, &c->loc); t = false; } } /* Switch off assumed size checking and do this again for certain kinds of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; if (csym) ptype = csym->attr.proc; no_formal_args = csym && is_external_proc (csym) && gfc_sym_get_dummy_args (csym) == NULL; if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) return false; /* Resume assumed_size checking. */ need_full_assumed_size--; /* If external, check for usage. */ if (csym && is_external_proc (csym)) resolve_global_procedure (csym, &c->loc, 1); t = true; if (c->resolved_sym == NULL) { c->resolved_isym = NULL; switch (procedure_kind (csym)) { case PTYPE_GENERIC: t = resolve_generic_s (c); break; case PTYPE_SPECIFIC: t = resolve_specific_s (c); break; case PTYPE_UNKNOWN: t = resolve_unknown_s (c); break; default: gfc_internal_error ("resolve_subroutine(): bad function type"); } } /* Some checks of elemental subroutine actual arguments. */ if (!resolve_elemental_actual (NULL, c)) return false; if (!c->expr1) update_current_proc_array_outer_dependency (csym); else /* Typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; return t; } /* Compare the shapes of two arrays that have non-NULL shapes. If both op1->shape and op2->shape are non-NULL return true if their shapes match. If both op1->shape and op2->shape are non-NULL return false if their shapes do not match. If either op1->shape or op2->shape is NULL, return true. */ static bool compare_shapes (gfc_expr *op1, gfc_expr *op2) { bool t; int i; t = true; if (op1->shape != NULL && op2->shape != NULL) { for (i = 0; i < op1->rank; i++) { if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) { gfc_error ("Shapes for operands at %L and %L are not conformable", &op1->where, &op2->where); t = false; break; } } } return t; } /* Convert a logical operator to the corresponding bitwise intrinsic call. For example A .AND. B becomes IAND(A, B). */ static gfc_expr * logical_to_bitwise (gfc_expr *e) { gfc_expr *tmp, *op1, *op2; gfc_isym_id isym; gfc_actual_arglist *args = NULL; gcc_assert (e->expr_type == EXPR_OP); isym = GFC_ISYM_NONE; op1 = e->value.op.op1; op2 = e->value.op.op2; switch (e->value.op.op) { case INTRINSIC_NOT: isym = GFC_ISYM_NOT; break; case INTRINSIC_AND: isym = GFC_ISYM_IAND; break; case INTRINSIC_OR: isym = GFC_ISYM_IOR; break; case INTRINSIC_NEQV: isym = GFC_ISYM_IEOR; break; case INTRINSIC_EQV: /* "Bitwise eqv" is just the complement of NEQV === IEOR. Change the old expression to NEQV, which will get replaced by IEOR, and wrap it in NOT. */ tmp = gfc_copy_expr (e); tmp->value.op.op = INTRINSIC_NEQV; tmp = logical_to_bitwise (tmp); isym = GFC_ISYM_NOT; op1 = tmp; op2 = NULL; break; default: gfc_internal_error ("logical_to_bitwise(): Bad intrinsic"); } /* Inherit the original operation's operands as arguments. */ args = gfc_get_actual_arglist (); args->expr = op1; if (op2) { args->next = gfc_get_actual_arglist (); args->next->expr = op2; } /* Convert the expression to a function call. */ e->expr_type = EXPR_FUNCTION; e->value.function.actual = args; e->value.function.isym = gfc_intrinsic_function_by_id (isym); e->value.function.name = e->value.function.isym->name; e->value.function.esym = NULL; /* Make up a pre-resolved function call symtree if we need to. */ if (!e->symtree || !e->symtree->n.sym) { gfc_symbol *sym; gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree); sym = e->symtree->n.sym; sym->result = sym; sym->attr.flavor = FL_PROCEDURE; sym->attr.function = 1; sym->attr.elemental = 1; sym->attr.pure = 1; sym->attr.referenced = 1; gfc_intrinsic_symbol (sym); gfc_commit_symbol (sym); } args->name = e->value.function.isym->formal->name; if (e->value.function.isym->formal->next) args->next->name = e->value.function.isym->formal->next->name; return e; } /* Recursively append candidate UOP to CANDIDATES. Store the number of candidates in CANDIDATES_LEN. */ static void lookup_uop_fuzzy_find_candidates (gfc_symtree *uop, char **&candidates, size_t &candidates_len) { gfc_symtree *p; if (uop == NULL) return; /* Not sure how to properly filter here. Use all for a start. n.uop.op is NULL for empty interface operators (is that legal?) disregard these as i suppose they don't make terribly sense. */ if (uop->n.uop->op != NULL) vec_push (candidates, candidates_len, uop->name); p = uop->left; if (p) lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); p = uop->right; if (p) lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); } /* Lookup user-operator OP fuzzily, taking names in UOP into account. */ static const char* lookup_uop_fuzzy (const char *op, gfc_symtree *uop) { char **candidates = NULL; size_t candidates_len = 0; lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len); return gfc_closest_fuzzy_match (op, candidates); } /* Callback finding an impure function as an operand to an .and. or .or. expression. Remember the last function warned about to avoid double warnings when recursing. */ static int impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) { gfc_expr *f = *e; const char *name; static gfc_expr *last = NULL; bool *found = (bool *) data; if (f->expr_type == EXPR_FUNCTION) { *found = 1; if (f != last && !gfc_pure_function (f, &name) && !gfc_implicit_pure_function (f)) { if (name) gfc_warning (OPT_Wfunction_elimination, "Impure function %qs at %L might not be evaluated", name, &f->where); else gfc_warning (OPT_Wfunction_elimination, "Impure function at %L might not be evaluated", &f->where); } last = f; } return 0; } /* Resolve an operator expression node. This can involve replacing the operation with a user defined function call. */ static bool resolve_operator (gfc_expr *e) { gfc_expr *op1, *op2; char msg[200]; bool dual_locus_error; bool t = true; /* Resolve all subnodes-- give them types. */ switch (e->value.op.op) { default: if (!gfc_resolve_expr (e->value.op.op2)) return false; /* Fall through. */ case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: case INTRINSIC_PARENTHESES: if (!gfc_resolve_expr (e->value.op.op1)) return false; if (e->value.op.op1 && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2) { gfc_error ("BOZ literal constant at %L cannot be an operand of " "unary operator %qs", &e->value.op.op1->where, gfc_op2string (e->value.op.op)); return false; } break; } /* Typecheck the new node. */ op1 = e->value.op.op1; op2 = e->value.op.op2; dual_locus_error = false; /* op1 and op2 cannot both be BOZ. */ if (op1 && op1->ts.type == BT_BOZ && op2 && op2->ts.type == BT_BOZ) { gfc_error ("Operands at %L and %L cannot appear as operands of " "binary operator %qs", &op1->where, &op2->where, gfc_op2string (e->value.op.op)); return false; } if ((op1 && op1->expr_type == EXPR_NULL) || (op2 && op2->expr_type == EXPR_NULL)) { sprintf (msg, _("Invalid context for NULL() pointer at %%L")); goto bad_op; } switch (e->value.op.op) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: if (op1->ts.type == BT_INTEGER || op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) { e->ts = op1->ts; break; } sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), gfc_op2string (e->value.op.op), gfc_typename (e)); goto bad_op; case INTRINSIC_PLUS: case INTRINSIC_MINUS: case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: case INTRINSIC_POWER: if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { gfc_type_convert_binary (e, 1); break; } if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) sprintf (msg, _("Unexpected derived-type entities in binary intrinsic " "numeric operator %%<%s%%> at %%L"), gfc_op2string (e->value.op.op)); else sprintf (msg, _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), gfc_op2string (e->value.op.op), gfc_typename (op1), gfc_typename (op2)); goto bad_op; case INTRINSIC_CONCAT: if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER && op1->ts.kind == op2->ts.kind) { e->ts.type = BT_CHARACTER; e->ts.kind = op1->ts.kind; break; } sprintf (msg, _("Operands of string concatenation operator at %%L are %s/%s"), gfc_typename (op1), gfc_typename (op2)); goto bad_op; case INTRINSIC_AND: case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) { e->ts.type = BT_LOGICAL; e->ts.kind = gfc_kind_max (op1, op2); if (op1->ts.kind < e->ts.kind) gfc_convert_type (op1, &e->ts, 2); else if (op2->ts.kind < e->ts.kind) gfc_convert_type (op2, &e->ts, 2); if (flag_frontend_optimize && (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)) { /* Warn about short-circuiting with impure function as second operand. */ bool op2_f = false; gfc_expr_walker (&op2, impure_function_callback, &op2_f); } break; } /* Logical ops on integers become bitwise ops with -fdec. */ else if (flag_dec && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER)) { e->ts.type = BT_INTEGER; e->ts.kind = gfc_kind_max (op1, op2); if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind) gfc_convert_type (op1, &e->ts, 1); if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind) gfc_convert_type (op2, &e->ts, 1); e = logical_to_bitwise (e); goto simplify_op; } sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), gfc_op2string (e->value.op.op), gfc_typename (op1), gfc_typename (op2)); goto bad_op; case INTRINSIC_NOT: /* Logical ops on integers become bitwise ops with -fdec. */ if (flag_dec && op1->ts.type == BT_INTEGER) { e->ts.type = BT_INTEGER; e->ts.kind = op1->ts.kind; e = logical_to_bitwise (e); goto simplify_op; } if (op1->ts.type == BT_LOGICAL) { e->ts.type = BT_LOGICAL; e->ts.kind = op1->ts.kind; break; } sprintf (msg, _("Operand of .not. operator at %%L is %s"), gfc_typename (op1)); goto bad_op; case INTRINSIC_GT: case INTRINSIC_GT_OS: case INTRINSIC_GE: case INTRINSIC_GE_OS: case INTRINSIC_LT: case INTRINSIC_LT_OS: case INTRINSIC_LE: case INTRINSIC_LE_OS: if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) { strcpy (msg, _("COMPLEX quantities cannot be compared at %L")); goto bad_op; } /* Fall through. */ case INTRINSIC_EQ: case INTRINSIC_EQ_OS: case INTRINSIC_NE: case INTRINSIC_NE_OS: if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER && op1->ts.kind == op2->ts.kind) { e->ts.type = BT_LOGICAL; e->ts.kind = gfc_default_logical_kind; break; } /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ if (op1->ts.type == BT_BOZ) { if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " "an operand of a relational operator", &op1->where)) return false; if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind)) return false; if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind)) return false; } /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */ if (op2->ts.type == BT_BOZ) { if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " "an operand of a relational operator", &op2->where)) return false; if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind)) return false; if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind)) return false; } if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { gfc_type_convert_binary (e, 1); e->ts.type = BT_LOGICAL; e->ts.kind = gfc_default_logical_kind; if (warn_compare_reals) { gfc_intrinsic_op op = e->value.op.op; /* Type conversion has made sure that the types of op1 and op2 agree, so it is only necessary to check the first one. */ if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE || op == INTRINSIC_NE_OS)) { const char *msg; if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) msg = "Equality comparison for %s at %L"; else msg = "Inequality comparison for %s at %L"; gfc_warning (OPT_Wcompare_reals, msg, gfc_typename (op1), &op1->where); } } break; } if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) sprintf (msg, _("Logicals at %%L must be compared with %s instead of %s"), (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS) ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); else sprintf (msg, _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), gfc_op2string (e->value.op.op), gfc_typename (op1), gfc_typename (op2)); goto bad_op; case INTRINSIC_USER: if (e->value.op.uop->op == NULL) { const char *name = e->value.op.uop->name; const char *guessed; guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root); if (guessed) sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), name, guessed); else sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name); } else if (op2 == NULL) sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"), e->value.op.uop->name, gfc_typename (op1)); else { sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"), e->value.op.uop->name, gfc_typename (op1), gfc_typename (op2)); e->value.op.uop->op->sym->attr.referenced = 1; } goto bad_op; case INTRINSIC_PARENTHESES: e->ts = op1->ts; if (e->ts.type == BT_CHARACTER) e->ts.u.cl = op1->ts.u.cl; break; default: gfc_internal_error ("resolve_operator(): Bad intrinsic"); } /* Deal with arrayness of an operand through an operator. */ switch (e->value.op.op) { case INTRINSIC_PLUS: case INTRINSIC_MINUS: case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: case INTRINSIC_POWER: case INTRINSIC_CONCAT: case INTRINSIC_AND: case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: case INTRINSIC_EQ: case INTRINSIC_EQ_OS: case INTRINSIC_NE: case INTRINSIC_NE_OS: case INTRINSIC_GT: case INTRINSIC_GT_OS: case INTRINSIC_GE: case INTRINSIC_GE_OS: case INTRINSIC_LT: case INTRINSIC_LT_OS: case INTRINSIC_LE: case INTRINSIC_LE_OS: if (op1->rank == 0 && op2->rank == 0) e->rank = 0; if (op1->rank == 0 && op2->rank != 0) { e->rank = op2->rank; if (e->shape == NULL) e->shape = gfc_copy_shape (op2->shape, op2->rank); } if (op1->rank != 0 && op2->rank == 0) { e->rank = op1->rank; if (e->shape == NULL) e->shape = gfc_copy_shape (op1->shape, op1->rank); } if (op1->rank != 0 && op2->rank != 0) { if (op1->rank == op2->rank) { e->rank = op1->rank; if (e->shape == NULL) { t = compare_shapes (op1, op2); if (!t) e->shape = NULL; else e->shape = gfc_copy_shape (op1->shape, op1->rank); } } else { /* Allow higher level expressions to work. */ e->rank = 0; /* Try user-defined operators, and otherwise throw an error. */ dual_locus_error = true; sprintf (msg, _("Inconsistent ranks for operator at %%L and %%L")); goto bad_op; } } break; case INTRINSIC_PARENTHESES: case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: /* Simply copy arrayness attribute */ e->rank = op1->rank; if (e->shape == NULL) e->shape = gfc_copy_shape (op1->shape, op1->rank); break; default: break; } simplify_op: /* Attempt to simplify the expression. */ if (t) { t = gfc_simplify_expr (e, 0); /* Some calls do not succeed in simplification and return false even though there is no error; e.g. variable references to PARAMETER arrays. */ if (!gfc_is_constant_expr (e)) t = true; } return t; bad_op: { match m = gfc_extend_expr (e); if (m == MATCH_YES) return true; if (m == MATCH_ERROR) return false; } if (dual_locus_error) gfc_error (msg, &op1->where, &op2->where); else gfc_error (msg, &e->where); return false; } /************** Array resolution subroutines **************/ enum compare_result { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }; /* Compare two integer expressions. */ static compare_result compare_bound (gfc_expr *a, gfc_expr *b) { int i; if (a == NULL || a->expr_type != EXPR_CONSTANT || b == NULL || b->expr_type != EXPR_CONSTANT) return CMP_UNKNOWN; /* If either of the types isn't INTEGER, we must have raised an error earlier. */ if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) return CMP_UNKNOWN; i = mpz_cmp (a->value.integer, b->value.integer); if (i < 0) return CMP_LT; if (i > 0) return CMP_GT; return CMP_EQ; } /* Compare an integer expression with an integer. */ static compare_result compare_bound_int (gfc_expr *a, int b) { int i; if (a == NULL || a->expr_type != EXPR_CONSTANT) return CMP_UNKNOWN; if (a->ts.type != BT_INTEGER) gfc_internal_error ("compare_bound_int(): Bad expression"); i = mpz_cmp_si (a->value.integer, b); if (i < 0) return CMP_LT; if (i > 0) return CMP_GT; return CMP_EQ; } /* Compare an integer expression with a mpz_t. */ static compare_result compare_bound_mpz_t (gfc_expr *a, mpz_t b) { int i; if (a == NULL || a->expr_type != EXPR_CONSTANT) return CMP_UNKNOWN; if (a->ts.type != BT_INTEGER) gfc_internal_error ("compare_bound_int(): Bad expression"); i = mpz_cmp (a->value.integer, b); if (i < 0) return CMP_LT; if (i > 0) return CMP_GT; return CMP_EQ; } /* Compute the last value of a sequence given by a triplet. Return 0 if it wasn't able to compute the last value, or if the sequence if empty, and 1 otherwise. */ static int compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, gfc_expr *stride, mpz_t last) { mpz_t rem; if (start == NULL || start->expr_type != EXPR_CONSTANT || end == NULL || end->expr_type != EXPR_CONSTANT || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) return 0; if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER || (stride != NULL && stride->ts.type != BT_INTEGER)) return 0; if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) { if (compare_bound (start, end) == CMP_GT) return 0; mpz_set (last, end->value.integer); return 1; } if (compare_bound_int (stride, 0) == CMP_GT) { /* Stride is positive */ if (mpz_cmp (start->value.integer, end->value.integer) > 0) return 0; } else { /* Stride is negative */ if (mpz_cmp (start->value.integer, end->value.integer) < 0) return 0; } mpz_init (rem); mpz_sub (rem, end->value.integer, start->value.integer); mpz_tdiv_r (rem, rem, stride->value.integer); mpz_sub (last, end->value.integer, rem); mpz_clear (rem); return 1; } /* Compare a single dimension of an array reference to the array specification. */ static bool check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { mpz_t last_value; if (ar->dimen_type[i] == DIMEN_STAR) { gcc_assert (ar->stride[i] == NULL); /* This implies [*] as [*:] and [*:3] are not possible. */ if (ar->start[i] == NULL) { gcc_assert (ar->end[i] == NULL); return true; } } /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ switch (ar->dimen_type[i]) { case DIMEN_VECTOR: case DIMEN_THIS_IMAGE: break; case DIMEN_STAR: case DIMEN_ELEMENT: if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) { if (i < as->rank) gfc_warning (0, "Array reference at %L is out of bounds " "(%ld < %ld) in dimension %d", &ar->c_where[i], mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->lower[i]->value.integer), i+1); else gfc_warning (0, "Array reference at %L is out of bounds " "(%ld < %ld) in codimension %d", &ar->c_where[i], mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->lower[i]->value.integer), i + 1 - as->rank); return true; } if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) { if (i < as->rank) gfc_warning (0, "Array reference at %L is out of bounds " "(%ld > %ld) in dimension %d", &ar->c_where[i], mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->upper[i]->value.integer), i+1); else gfc_warning (0, "Array reference at %L is out of bounds " "(%ld > %ld) in codimension %d", &ar->c_where[i], mpz_get_si (ar->start[i]->value.integer), mpz_get_si (as->upper[i]->value.integer), i + 1 - as->rank); return true; } break; case DIMEN_RANGE: { #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) compare_result comp_start_end = compare_bound (AR_START, AR_END); /* Check for zero stride, which is not allowed. */ if (compare_bound_int (ar->stride[i], 0) == CMP_EQ) { gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); return false; } /* if start == len || (stride > 0 && start < len) || (stride < 0 && start > len), then the array section contains at least one element. In this case, there is an out-of-bounds access if (start < lower || start > upper). */ if (compare_bound (AR_START, AR_END) == CMP_EQ || ((compare_bound_int (ar->stride[i], 0) == CMP_GT || ar->stride[i] == NULL) && comp_start_end == CMP_LT) || (compare_bound_int (ar->stride[i], 0) == CMP_LT && comp_start_end == CMP_GT)) { if (compare_bound (AR_START, as->lower[i]) == CMP_LT) { gfc_warning (0, "Lower array reference at %L is out of bounds " "(%ld < %ld) in dimension %d", &ar->c_where[i], mpz_get_si (AR_START->value.integer), mpz_get_si (as->lower[i]->value.integer), i+1); return true; } if (compare_bound (AR_START, as->upper[i]) == CMP_GT) { gfc_warning (0, "Lower array reference at %L is out of bounds " "(%ld > %ld) in dimension %d", &ar->c_where[i], mpz_get_si (AR_START->value.integer), mpz_get_si (as->upper[i]->value.integer), i+1); return true; } } /* If we can compute the highest index of the array section, then it also has to be between lower and upper. */ mpz_init (last_value); if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], last_value)) { if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT) { gfc_warning (0, "Upper array reference at %L is out of bounds " "(%ld < %ld) in dimension %d", &ar->c_where[i], mpz_get_si (last_value), mpz_get_si (as->lower[i]->value.integer), i+1); mpz_clear (last_value); return true; } if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) { gfc_warning (0, "Upper array reference at %L is out of bounds " "(%ld > %ld) in dimension %d", &ar->c_where[i], mpz_get_si (last_value), mpz_get_si (as->upper[i]->value.integer), i+1); mpz_clear (last_value); return true; } } mpz_clear (last_value); #undef AR_START #undef AR_END } break; default: gfc_internal_error ("check_dimension(): Bad array reference"); } return true; } /* Compare an array reference with an array specification. */ static bool compare_spec_to_ref (gfc_array_ref *ar) { gfc_array_spec *as; int i; as = ar->as; i = as->rank - 1; /* TODO: Full array sections are only allowed as actual parameters. */ if (as->type == AS_ASSUMED_SIZE && (/*ar->type == AR_FULL ||*/ (ar->type == AR_SECTION && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) { gfc_error ("Rightmost upper bound of assumed size array section " "not specified at %L", &ar->where); return false; } if (ar->type == AR_FULL) return true; if (as->rank != ar->dimen) { gfc_error ("Rank mismatch in array reference at %L (%d/%d)", &ar->where, ar->dimen, as->rank); return false; } /* ar->codimen == 0 is a local array. */ if (as->corank != ar->codimen && ar->codimen != 0) { gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", &ar->where, ar->codimen, as->corank); return false; } for (i = 0; i < as->rank; i++) if (!check_dimension (i, ar, as)) return false; /* Local access has no coarray spec. */ if (ar->codimen != 0) for (i = as->rank; i < as->rank + as->corank; i++) { if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate && ar->dimen_type[i] != DIMEN_THIS_IMAGE) { gfc_error ("Coindex of codimension %d must be a scalar at %L", i + 1 - as->rank, &ar->where); return false; } if (!check_dimension (i, ar, as)) return false; } return true; } /* Resolve one part of an array index. */ static bool gfc_resolve_index_1 (gfc_expr *index, int check_scalar, int force_index_integer_kind) { gfc_typespec ts; if (index == NULL) return true; if (!gfc_resolve_expr (index)) return false; if (check_scalar && index->rank != 0) { gfc_error ("Array index at %L must be scalar", &index->where); return false; } if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) { gfc_error ("Array index at %L must be of INTEGER type, found %s", &index->where, gfc_basic_typename (index->ts.type)); return false; } if (index->ts.type == BT_REAL) if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", &index->where)) return false; if ((index->ts.kind != gfc_index_integer_kind && force_index_integer_kind) || index->ts.type != BT_INTEGER) { gfc_clear_ts (&ts); ts.type = BT_INTEGER; ts.kind = gfc_index_integer_kind; gfc_convert_type_warn (index, &ts, 2, 0); } return true; } /* Resolve one part of an array index. */ bool gfc_resolve_index (gfc_expr *index, int check_scalar) { return gfc_resolve_index_1 (index, check_scalar, 1); } /* Resolve a dim argument to an intrinsic function. */ bool gfc_resolve_dim_arg (gfc_expr *dim) { if (dim == NULL) return true; if (!gfc_resolve_expr (dim)) return false; if (dim->rank != 0) { gfc_error ("Argument dim at %L must be scalar", &dim->where); return false; } if (dim->ts.type != BT_INTEGER) { gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); return false; } if (dim->ts.kind != gfc_index_integer_kind) { gfc_typespec ts; gfc_clear_ts (&ts); ts.type = BT_INTEGER; ts.kind = gfc_index_integer_kind; gfc_convert_type_warn (dim, &ts, 2, 0); } return true; } /* Given an expression that contains array references, update those array references to point to the right array specifications. While this is filled in during matching, this information is difficult to save and load in a module, so we take care of it here. The idea here is that the original array reference comes from the base symbol. We traverse the list of reference structures, setting the stored reference to references. Component references can provide an additional array specification. */ static void find_array_spec (gfc_expr *e) { gfc_array_spec *as; gfc_component *c; gfc_ref *ref; bool class_as = false; if (e->symtree->n.sym->ts.type == BT_CLASS) { as = CLASS_DATA (e->symtree->n.sym)->as; class_as = true; } else as = e->symtree->n.sym->as; for (ref = e->ref; ref; ref = ref->next) switch (ref->type) { case REF_ARRAY: if (as == NULL) gfc_internal_error ("find_array_spec(): Missing spec"); ref->u.ar.as = as; as = NULL; break; case REF_COMPONENT: c = ref->u.c.component; if (c->attr.dimension) { if (as != NULL && !(class_as && as == c->as)) gfc_internal_error ("find_array_spec(): unused as(1)"); as = c->as; } break; case REF_SUBSTRING: case REF_INQUIRY: break; } if (as != NULL) gfc_internal_error ("find_array_spec(): unused as(2)"); } /* Resolve an array reference. */ static bool resolve_array_ref (gfc_array_ref *ar) { int i, check_scalar; gfc_expr *e; for (i = 0; i < ar->dimen + ar->codimen; i++) { check_scalar = ar->dimen_type[i] == DIMEN_RANGE; /* Do not force gfc_index_integer_kind for the start. We can do fine with any integer kind. This avoids temporary arrays created for indexing with a vector. */ if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0)) return false; if (!gfc_resolve_index (ar->end[i], check_scalar)) return false; if (!gfc_resolve_index (ar->stride[i], check_scalar)) return false; e = ar->start[i]; if (ar->dimen_type[i] == DIMEN_UNKNOWN) switch (e->rank) { case 0: ar->dimen_type[i] = DIMEN_ELEMENT; break; case 1: ar->dimen_type[i] = DIMEN_VECTOR; if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->ts.type == BT_DERIVED) ar->start[i] = gfc_get_parentheses (e); break; default: gfc_error ("Array index at %L is an array of rank %d", &ar->c_where[i], e->rank); return false; } /* Fill in the upper bound, which may be lower than the specified one for something like a(2:10:5), which is identical to a(2:7:5). Only relevant for strides not equal to one. Don't try a division by zero. */ if (ar->dimen_type[i] == DIMEN_RANGE && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) { mpz_t size, end; if (gfc_ref_dimen_size (ar, i, &size, &end)) { if (ar->end[i] == NULL) { ar->end[i] = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, &ar->where); mpz_set (ar->end[i]->value.integer, end); } else if (ar->end[i]->ts.type == BT_INTEGER && ar->end[i]->expr_type == EXPR_CONSTANT) { mpz_set (ar->end[i]->value.integer, end); } else gcc_unreachable (); mpz_clear (size); mpz_clear (end); } } } if (ar->type == AR_FULL) { if (ar->as->rank == 0) ar->type = AR_ELEMENT; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ ar->dimen = ar->as->rank; for (i = 0; i < ar->dimen; i++) { ar->dimen_type[i] = DIMEN_RANGE; gcc_assert (ar->start[i] == NULL); gcc_assert (ar->end[i] == NULL); gcc_assert (ar->stride[i] == NULL); } } /* If the reference type is unknown, figure out what kind it is. */ if (ar->type == AR_UNKNOWN) { ar->type = AR_ELEMENT; for (i = 0; i < ar->dimen; i++) if (ar->dimen_type[i] == DIMEN_RANGE || ar->dimen_type[i] == DIMEN_VECTOR) { ar->type = AR_SECTION; break; } } if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) return false; if (ar->as->corank && ar->codimen == 0) { int n; ar->codimen = ar->as->corank; for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) ar->dimen_type[n] = DIMEN_THIS_IMAGE; } return true; } static bool resolve_substring (gfc_ref *ref, bool *equal_length) { int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); if (ref->u.ss.start != NULL) { if (!gfc_resolve_expr (ref->u.ss.start)) return false; if (ref->u.ss.start->ts.type != BT_INTEGER) { gfc_error ("Substring start index at %L must be of type INTEGER", &ref->u.ss.start->where); return false; } if (ref->u.ss.start->rank != 0) { gfc_error ("Substring start index at %L must be scalar", &ref->u.ss.start->where); return false; } if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) { gfc_error ("Substring start index at %L is less than one", &ref->u.ss.start->where); return false; } } if (ref->u.ss.end != NULL) { if (!gfc_resolve_expr (ref->u.ss.end)) return false; if (ref->u.ss.end->ts.type != BT_INTEGER) { gfc_error ("Substring end index at %L must be of type INTEGER", &ref->u.ss.end->where); return false; } if (ref->u.ss.end->rank != 0) { gfc_error ("Substring end index at %L must be scalar", &ref->u.ss.end->where); return false; } if (ref->u.ss.length != NULL && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) { gfc_error ("Substring end index at %L exceeds the string length", &ref->u.ss.start->where); return false; } if (compare_bound_mpz_t (ref->u.ss.end, gfc_integer_kinds[k].huge) == CMP_GT && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) { gfc_error ("Substring end index at %L is too large", &ref->u.ss.end->where); return false; } /* If the substring has the same length as the original variable, the reference itself can be deleted. */ if (ref->u.ss.length != NULL && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ) *equal_length = true; } return true; } /* This function supplies missing substring charlens. */ void gfc_resolve_substring_charlen (gfc_expr *e) { gfc_ref *char_ref; gfc_expr *start, *end; gfc_typespec *ts = NULL; mpz_t diff; for (char_ref = e->ref; char_ref; char_ref = char_ref->next) { if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) break; if (char_ref->type == REF_COMPONENT) ts = &char_ref->u.c.component->ts; } if (!char_ref || char_ref->type == REF_INQUIRY) return; gcc_assert (char_ref->next == NULL); if (e->ts.u.cl) { if (e->ts.u.cl->length) gfc_free_expr (e->ts.u.cl->length); else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) return; } e->ts.type = BT_CHARACTER; e->ts.kind = gfc_default_character_kind; if (!e->ts.u.cl) e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); else start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); if (char_ref->u.ss.end) end = gfc_copy_expr (char_ref->u.ss.end); else if (e->expr_type == EXPR_VARIABLE) { if (!ts) ts = &e->symtree->n.sym->ts; end = gfc_copy_expr (ts->u.cl->length); } else end = NULL; if (!start || !end) { gfc_free_expr (start); gfc_free_expr (end); return; } /* Length = (end - start + 1). Check first whether it has a constant length. */ if (gfc_dep_difference (end, start, &diff)) { gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, &e->where); mpz_add_ui (len->value.integer, diff, 1); mpz_clear (diff); e->ts.u.cl->length = len; /* The check for length < 0 is handled below */ } else { e->ts.u.cl->length = gfc_subtract (end, start); e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1)); } /* F2008, 6.4.1: Both the starting point and the ending point shall be within the range 1, 2, ..., n unless the starting point exceeds the ending point, in which case the substring has length zero. */ if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0) mpz_set_si (e->ts.u.cl->length->value.integer, 0); e->ts.u.cl->length->ts.type = BT_INTEGER; e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; /* Make sure that the length is simplified. */ gfc_simplify_expr (e->ts.u.cl->length, 1); gfc_resolve_expr (e->ts.u.cl->length); } /* Resolve subtype references. */ static bool resolve_ref (gfc_expr *expr) { int current_part_dimension, n_components, seen_part_dimension; gfc_ref *ref, **prev; bool equal_length; for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) { find_array_spec (expr); break; } for (prev = &expr->ref; *prev != NULL; prev = *prev == NULL ? prev : &(*prev)->next) switch ((*prev)->type) { case REF_ARRAY: if (!resolve_array_ref (&(*prev)->u.ar)) return false; break; case REF_COMPONENT: case REF_INQUIRY: break; case REF_SUBSTRING: equal_length = false; if (!resolve_substring (*prev, &equal_length)) return false; if (expr->expr_type != EXPR_SUBSTRING && equal_length) { /* Remove the reference and move the charlen, if any. */ ref = *prev; *prev = ref->next; ref->next = NULL; expr->ts.u.cl = ref->u.ss.length; ref->u.ss.length = NULL; gfc_free_ref_list (ref); } break; } /* Check constraints on part references. */ current_part_dimension = 0; seen_part_dimension = 0; n_components = 0; for (ref = expr->ref; ref; ref = ref->next) { switch (ref->type) { case REF_ARRAY: switch (ref->u.ar.type) { case AR_FULL: /* Coarray scalar. */ if (ref->u.ar.as->rank == 0) { current_part_dimension = 0; break; } /* Fall through. */ case AR_SECTION: current_part_dimension = 1; break; case AR_ELEMENT: current_part_dimension = 0; break; case AR_UNKNOWN: gfc_internal_error ("resolve_ref(): Bad array reference"); } break; case REF_COMPONENT: if (current_part_dimension || seen_part_dimension) { /* F03:C614. */ if (ref->u.c.component->attr.pointer || ref->u.c.component->attr.proc_pointer || (ref->u.c.component->ts.type == BT_CLASS && CLASS_DATA (ref->u.c.component)->attr.pointer)) { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the POINTER " "attribute at %L", &expr->where); return false; } else if (ref->u.c.component->attr.allocatable || (ref->u.c.component->ts.type == BT_CLASS && CLASS_DATA (ref->u.c.component)->attr.allocatable)) { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the ALLOCATABLE " "attribute at %L", &expr->where); return false; } } n_components++; break; case REF_SUBSTRING: case REF_INQUIRY: break; } if (((ref->type == REF_COMPONENT && n_components > 1) || ref->next == NULL) && current_part_dimension && seen_part_dimension) { gfc_error ("Two or more part references with nonzero rank must " "not be specified at %L", &expr->where); return false; } if (ref->type == REF_COMPONENT) { if (current_part_dimension) seen_part_dimension = 1; /* reset to make sure */ current_part_dimension = 0; } } return true; } /* Given an expression, determine its shape. This is easier than it sounds. Leaves the shape array NULL if it is not possible to determine the shape. */ static void expression_shape (gfc_expr *e) { mpz_t array[GFC_MAX_DIMENSIONS]; int i; if (e->rank <= 0 || e->shape != NULL) return; for (i = 0; i < e->rank; i++) if (!gfc_array_dimen_size (e, i, &array[i])) goto fail; e->shape = gfc_get_shape (e->rank); memcpy (e->shape, array, e->rank * sizeof (mpz_t)); return; fail: for (i--; i >= 0; i--) mpz_clear (array[i]); } /* Given a variable expression node, compute the rank of the expression by examining the base symbol and any reference structures it may have. */ void expression_rank (gfc_expr *e) { gfc_ref *ref; int i, rank; /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that could lead to serious confusion... */ gcc_assert (e->expr_type != EXPR_COMPCALL); if (e->ref == NULL) { if (e->expr_type == EXPR_ARRAY) goto done; /* Constructors can have a rank different from one via RESHAPE(). */ if (e->symtree == NULL) { e->rank = 0; goto done; } e->rank = (e->symtree->n.sym->as == NULL) ? 0 : e->symtree->n.sym->as->rank; goto done; } rank = 0; for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer && ref->u.c.component->attr.function && !ref->next) rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0; if (ref->type != REF_ARRAY) continue; if (ref->u.ar.type == AR_FULL) { rank = ref->u.ar.as->rank; break; } if (ref->u.ar.type == AR_SECTION) { /* Figure out the rank of the section. */ if (rank != 0) gfc_internal_error ("expression_rank(): Two array specs"); for (i = 0; i < ref->u.ar.dimen; i++) if (ref->u.ar.dimen_type[i] == DIMEN_RANGE || ref->u.ar.dimen_type[i] == DIMEN_VECTOR) rank++; break; } } e->rank = rank; done: expression_shape (e); } static void add_caf_get_intrinsic (gfc_expr *e) { gfc_expr *wrapper, *tmp_expr; gfc_ref *ref; int n; for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) break; if (ref == NULL) return; for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) return; tmp_expr = XCNEW (gfc_expr); *tmp_expr = *e; wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, "caf_get", tmp_expr->where, 1, tmp_expr); wrapper->ts = e->ts; wrapper->rank = e->rank; if (e->rank) wrapper->shape = gfc_copy_shape (e->shape, e->rank); *e = *wrapper; free (wrapper); } static void remove_caf_get_intrinsic (gfc_expr *e) { gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym && e->value.function.isym->id == GFC_ISYM_CAF_GET); gfc_expr *e2 = e->value.function.actual->expr; e->value.function.actual->expr = NULL; gfc_free_actual_arglist (e->value.function.actual); gfc_free_shape (&e->shape, e->rank); *e = *e2; free (e2); } /* Resolve a variable expression. */ static bool resolve_variable (gfc_expr *e) { gfc_symbol *sym; bool t; t = true; if (e->symtree == NULL) return false; sym = e->symtree->n.sym; /* Use same check as for TYPE(*) below; this check has to be before TYPE(*) as ts.type is set to BT_ASSUMED in resolve_symbol. */ if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) { if (!actual_arg || inquiry_argument) { gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only " "be used as actual argument", sym->name, &e->where); return false; } } /* TS 29113, 407b. */ else if (e->ts.type == BT_ASSUMED) { if (!actual_arg) { gfc_error ("Assumed-type variable %s at %L may only be used " "as actual argument", sym->name, &e->where); return false; } else if (inquiry_argument && !first_actual_arg) { /* FIXME: It doesn't work reliably as inquiry_argument is not set for all inquiry functions in resolve_function; the reason is that the function-name resolution happens too late in that function. */ gfc_error ("Assumed-type variable %s at %L as actual argument to " "an inquiry function shall be the first argument", sym->name, &e->where); return false; } } /* TS 29113, C535b. */ else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) || (sym->ts.type != BT_CLASS && sym->as && sym->as->type == AS_ASSUMED_RANK)) && !sym->attr.select_rank_temporary) { if (!actual_arg && !(cs_base && cs_base->current && cs_base->current->op == EXEC_SELECT_RANK)) { gfc_error ("Assumed-rank variable %s at %L may only be used as " "actual argument", sym->name, &e->where); return false; } else if (inquiry_argument && !first_actual_arg) { /* FIXME: It doesn't work reliably as inquiry_argument is not set for all inquiry functions in resolve_function; the reason is that the function-name resolution happens too late in that function. */ gfc_error ("Assumed-rank variable %s at %L as actual argument " "to an inquiry function shall be the first argument", sym->name, &e->where); return false; } } if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL && e->ref->next == NULL)) { gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have " "a subobject reference", sym->name, &e->ref->u.ar.where); return false; } /* TS 29113, 407b. */ else if (e->ts.type == BT_ASSUMED && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL && e->ref->next == NULL)) { gfc_error ("Assumed-type variable %s at %L shall not have a subobject " "reference", sym->name, &e->ref->u.ar.where); return false; } /* TS 29113, C535b. */ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) || (sym->ts.type != BT_CLASS && sym->as && sym->as->type == AS_ASSUMED_RANK)) && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL && e->ref->next == NULL)) { gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " "reference", sym->name, &e->ref->u.ar.where); return false; } /* For variables that are used in an associate (target => object) where the object's basetype is array valued while the target is scalar, the ts' type of the component refs is still array valued, which can't be translated that way. */ if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS && CLASS_DATA (sym->assoc->target)->as) { gfc_ref *ref = e->ref; while (ref) { switch (ref->type) { case REF_COMPONENT: ref->u.c.sym = sym->ts.u.derived; /* Stop the loop. */ ref = NULL; break; default: ref = ref->next; break; } } } /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) { if (sym->ts.type == BT_CLASS) gfc_fix_class_refs (e); if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) return false; else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) { /* This can happen because the parser did not detect that the associate name is an array and the expression had no array part_ref. */ gfc_ref *ref = gfc_get_ref (); ref->type = REF_ARRAY; ref->u.ar = *gfc_get_array_ref(); ref->u.ar.type = AR_FULL; if (sym->as) { ref->u.ar.as = sym->as; ref->u.ar.dimen = sym->as->rank; } ref->next = e->ref; e->ref = ref; } } if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); /* On the other hand, the parser may not have known this is an array; in this case, we have to add a FULL reference. */ if (sym->assoc && sym->attr.dimension && !e->ref) { e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; e->ref->u.ar.dimen = 0; } /* Like above, but for class types, where the checking whether an array ref is present is more complicated. Furthermore make sure not to add the full array ref to _vptr or _len refs. */ if (sym->assoc && sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) { gfc_ref *ref, *newref; newref = gfc_get_ref (); newref->type = REF_ARRAY; newref->u.ar.type = AR_FULL; newref->u.ar.dimen = 0; /* Because this is an associate var and the first ref either is a ref to the _data component or not, no traversal of the ref chain is needed. The array ref needs to be inserted after the _data ref, or when that is not present, which may happend for polymorphic types, then at the first position. */ ref = e->ref; if (!ref) e->ref = newref; else if (ref->type == REF_COMPONENT && strcmp ("_data", ref->u.c.component->name) == 0) { if (!ref->next || ref->next->type != REF_ARRAY) { newref->next = ref->next; ref->next = newref; } else /* Array ref present already. */ gfc_free_ref_list (newref); } else if (ref->type == REF_ARRAY) /* Array ref present already. */ gfc_free_ref_list (newref); else { newref->next = ref; e->ref = newref; } } if (e->ref && !resolve_ref (e)) return false; if (sym->attr.flavor == FL_PROCEDURE && (!sym->attr.function || (sym->attr.function && sym->result && sym->result->attr.proc_pointer && !sym->result->attr.function))) { e->ts.type = BT_PROCEDURE; goto resolve_procedure; } if (sym->ts.type != BT_UNKNOWN) gfc_variable_attr (e, &e->ts); else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function && sym->result && sym->result->ts.type != BT_UNKNOWN && sym->result->attr.proc_pointer) e->ts = sym->result->ts; else { /* Must be a simple variable reference. */ if (!gfc_set_default_type (sym, 1, sym->ns)) return false; e->ts = sym->ts; } if (check_assumed_size_reference (sym, e)) return false; /* Deal with forward references to entries during gfc_resolve_code, to satisfy, at least partially, 12.5.2.5. */ if (gfc_current_ns->entries && current_entry_id == sym->entry_id && cs_base && cs_base->current && cs_base->current->op != EXEC_ENTRY) { gfc_entry_list *entry; gfc_formal_arglist *formal; int n; bool seen, saved_specification_expr; /* If the symbol is a dummy... */ if (sym->attr.dummy && sym->ns == gfc_current_ns) { entry = gfc_current_ns->entries; seen = false; /* ...test if the symbol is a parameter of previous entries. */ for (; entry && entry->id <= current_entry_id; entry = entry->next) for (formal = entry->sym->formal; formal; formal = formal->next) { if (formal->sym && sym->name == formal->sym->name) { seen = true; break; } } /* If it has not been seen as a dummy, this is an error. */ if (!seen) { if (specification_expr) gfc_error ("Variable %qs, used in a specification expression" ", is referenced at %L before the ENTRY statement " "in which it is a parameter", sym->name, &cs_base->current->loc); else gfc_error ("Variable %qs is used at %L before the ENTRY " "statement in which it is a parameter", sym->name, &cs_base->current->loc); t = false; } } /* Now do the same check on the specification expressions. */ saved_specification_expr = specification_expr; specification_expr = true; if (sym->ts.type == BT_CHARACTER && !gfc_resolve_expr (sym->ts.u.cl->length)) t = false; if (sym->as) for (n = 0; n < sym->as->rank; n++) { if (!gfc_resolve_expr (sym->as->lower[n])) t = false; if (!gfc_resolve_expr (sym->as->upper[n])) t = false; } specification_expr = saved_specification_expr; if (t) /* Update the symbol's entry level. */ sym->entry_id = current_entry_id + 1; } /* If a symbol has been host_associated mark it. This is used latter, to identify if aliasing is possible via host association. */ if (sym->attr.flavor == FL_VARIABLE && gfc_current_ns->parent && (gfc_current_ns->parent == sym->ns || (gfc_current_ns->parent->parent && gfc_current_ns->parent->parent == sym->ns))) sym->attr.host_assoc = 1; if (gfc_current_ns->proc_name && sym->attr.dimension && (sym->ns != gfc_current_ns || sym->attr.use_assoc || sym->attr.in_common)) gfc_current_ns->proc_name->attr.array_outer_dependency = 1; resolve_procedure: if (t && !resolve_procedure_expression (e)) t = false; /* F2008, C617 and C1229. */ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) && gfc_is_coindexed (e)) { gfc_ref *ref, *ref2 = NULL; for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT) ref2 = ref; if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) break; } for ( ; ref; ref = ref->next) if (ref->type == REF_COMPONENT) break; /* Expression itself is not coindexed object. */ if (ref && e->ts.type == BT_CLASS) { gfc_error ("Polymorphic subobject of coindexed object at %L", &e->where); t = false; } /* Expression itself is coindexed object. */ if (ref == NULL) { gfc_component *c; c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; for ( ; c; c = c->next) if (c->attr.allocatable && c->ts.type == BT_CLASS) { gfc_error ("Coindexed object with polymorphic allocatable " "subcomponent at %L", &e->where); t = false; break; } } } if (t) expression_rank (e); if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) add_caf_get_intrinsic (e); /* Simplify cases where access to a parameter array results in a single constant. Suppress errors since those will have been issued before, as warnings. */ if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER) { gfc_push_suppress_errors (); gfc_simplify_expr (e, 1); gfc_pop_suppress_errors (); } return t; } /* Checks to see that the correct symbol has been host associated. The only situation where this arises is that in which a twice contained function is parsed after the host association is made. Therefore, on detecting this, change the symbol in the expression and convert the array reference into an actual arglist if the old symbol is a variable. */ static bool check_host_association (gfc_expr *e) { gfc_symbol *sym, *old_sym; gfc_symtree *st; int n; gfc_ref *ref; gfc_actual_arglist *arg, *tail = NULL; bool retval = e->expr_type == EXPR_FUNCTION; /* If the expression is the result of substitution in interface.c(gfc_extend_expr) because there is no way in which the host association can be wrong. */ if (e->symtree == NULL || e->symtree->n.sym == NULL || e->user_operator) return retval; old_sym = e->symtree->n.sym; if (gfc_current_ns->parent && old_sym->ns != gfc_current_ns) { /* Use the 'USE' name so that renamed module symbols are correctly handled. */ gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym); if (sym && old_sym != sym && sym->ts.type == old_sym->ts.type && sym->attr.flavor == FL_PROCEDURE && sym->attr.contained) { /* Clear the shape, since it might not be valid. */ gfc_free_shape (&e->shape, e->rank); /* Give the expression the right symtree! */ gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); gcc_assert (st != NULL); if (old_sym->attr.flavor == FL_PROCEDURE || e->expr_type == EXPR_FUNCTION) { /* Original was function so point to the new symbol, since the actual argument list is already attached to the expression. */ e->value.function.esym = NULL; e->symtree = st; } else { /* Original was variable so convert array references into an actual arglist. This does not need any checking now since resolve_function will take care of it. */ e->value.function.actual = NULL; e->expr_type = EXPR_FUNCTION; e->symtree = st; /* Ambiguity will not arise if the array reference is not the last reference. */ for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->next == NULL) break; gcc_assert (ref->type == REF_ARRAY); /* Grab the start expressions from the array ref and copy them into actual arguments. */ for (n = 0; n < ref->u.ar.dimen; n++) { arg = gfc_get_actual_arglist (); arg->expr = gfc_copy_expr (ref->u.ar.start[n]); if (e->value.function.actual == NULL) tail = e->value.function.actual = arg; else { tail->next = arg; tail = arg; } } /* Dump the reference list and set the rank. */ gfc_free_ref_list (e->ref); e->ref = NULL; e->rank = sym->as ? sym->as->rank : 0; } gfc_resolve_expr (e); sym->refs++; } } /* This might have changed! */ return e->expr_type == EXPR_FUNCTION; } static void gfc_resolve_character_operator (gfc_expr *e) { gfc_expr *op1 = e->value.op.op1; gfc_expr *op2 = e->value.op.op2; gfc_expr *e1 = NULL; gfc_expr *e2 = NULL; gcc_assert (e->value.op.op == INTRINSIC_CONCAT); if (op1->ts.u.cl && op1->ts.u.cl->length) e1 = gfc_copy_expr (op1->ts.u.cl->length); else if (op1->expr_type == EXPR_CONSTANT) e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, op1->value.character.length); if (op2->ts.u.cl && op2->ts.u.cl->length) e2 = gfc_copy_expr (op2->ts.u.cl->length); else if (op2->expr_type == EXPR_CONSTANT) e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, op2->value.character.length); e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); if (!e1 || !e2) { gfc_free_expr (e1); gfc_free_expr (e2); return; } e->ts.u.cl->length = gfc_add (e1, e2); e->ts.u.cl->length->ts.type = BT_INTEGER; e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; gfc_simplify_expr (e->ts.u.cl->length, 0); gfc_resolve_expr (e->ts.u.cl->length); return; } /* Ensure that an character expression has a charlen and, if possible, a length expression. */ static void fixup_charlen (gfc_expr *e) { /* The cases fall through so that changes in expression type and the need for multiple fixes are picked up. In all circumstances, a charlen should be available for the middle end to hang a backend_decl on. */ switch (e->expr_type) { case EXPR_OP: gfc_resolve_character_operator (e); /* FALLTHRU */ case EXPR_ARRAY: if (e->expr_type == EXPR_ARRAY) gfc_resolve_character_array_constructor (e); /* FALLTHRU */ case EXPR_SUBSTRING: if (!e->ts.u.cl && e->ref) gfc_resolve_substring_charlen (e); /* FALLTHRU */ default: if (!e->ts.u.cl) e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); break; } } /* Update an actual argument to include the passed-object for type-bound procedures at the right position. */ static gfc_actual_arglist* update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, const char *name) { gcc_assert (argpos > 0); if (argpos == 1) { gfc_actual_arglist* result; result = gfc_get_actual_arglist (); result->expr = po; result->next = lst; if (name) result->name = name; return result; } if (lst) lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); else lst = update_arglist_pass (NULL, po, argpos - 1, name); return lst; } /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */ static gfc_expr* extract_compcall_passed_object (gfc_expr* e) { gfc_expr* po; if (e->expr_type == EXPR_UNKNOWN) { gfc_error ("Error in typebound call at %L", &e->where); return NULL; } gcc_assert (e->expr_type == EXPR_COMPCALL); if (e->value.compcall.base_object) po = gfc_copy_expr (e->value.compcall.base_object); else { po = gfc_get_expr (); po->expr_type = EXPR_VARIABLE; po->symtree = e->symtree; po->ref = gfc_copy_ref (e->ref); po->where = e->where; } if (!gfc_resolve_expr (po)) return NULL; return po; } /* Update the arglist of an EXPR_COMPCALL expression to include the passed-object. */ static bool update_compcall_arglist (gfc_expr* e) { gfc_expr* po; gfc_typebound_proc* tbp; tbp = e->value.compcall.tbp; if (tbp->error) return false; po = extract_compcall_passed_object (e); if (!po) return false; if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); return true; } if (tbp->pass_arg_num <= 0) return false; e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, tbp->pass_arg_num, tbp->pass_arg); return true; } /* Extract the passed object from a PPC call (a copy of it). */ static gfc_expr* extract_ppc_passed_object (gfc_expr *e) { gfc_expr *po; gfc_ref **ref; po = gfc_get_expr (); po->expr_type = EXPR_VARIABLE; po->symtree = e->symtree; po->ref = gfc_copy_ref (e->ref); po->where = e->where; /* Remove PPC reference. */ ref = &po->ref; while ((*ref)->next) ref = &(*ref)->next; gfc_free_ref_list (*ref); *ref = NULL; if (!gfc_resolve_expr (po)) return NULL; return po; } /* Update the actual arglist of a procedure pointer component to include the passed-object. */ static bool update_ppc_arglist (gfc_expr* e) { gfc_expr* po; gfc_component *ppc; gfc_typebound_proc* tb; ppc = gfc_get_proc_ptr_comp (e); if (!ppc) return false; tb = ppc->tb; if (tb->error) return false; else if (tb->nopass) return true; po = extract_ppc_passed_object (e); if (!po) return false; /* F08:R739. */ if (po->rank != 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); return false; } /* F08:C611. */ if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract) { gfc_error ("Base object for procedure-pointer component call at %L is of" " ABSTRACT type %qs", &e->where, po->ts.u.derived->name); return false; } gcc_assert (tb->pass_arg_num > 0); e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, tb->pass_arg_num, tb->pass_arg); return true; } /* Check that the object a TBP is called on is valid, i.e. it must not be of ABSTRACT type (as in subobject%abstract_parent%tbp()). */ static bool check_typebound_baseobject (gfc_expr* e) { gfc_expr* base; bool return_value = false; base = extract_compcall_passed_object (e); if (!base) return false; if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS) { gfc_error ("Error in typebound call at %L", &e->where); goto cleanup; } if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) return false; /* F08:C611. */ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" " ABSTRACT type %qs", &e->where, base->ts.u.derived->name); goto cleanup; } /* F08:C1230. If the procedure called is NOPASS, the base object must be scalar. */ if (e->value.compcall.tbp->nopass && base->rank != 0) { gfc_error ("Base object for NOPASS type-bound procedure call at %L must" " be scalar", &e->where); goto cleanup; } return_value = true; cleanup: gfc_free_expr (base); return return_value; } /* Resolve a call to a type-bound procedure, either function or subroutine, statically from the data in an EXPR_COMPCALL expression. The adapted arglist and the target-procedure symtree are returned. */ static bool resolve_typebound_static (gfc_expr* e, gfc_symtree** target, gfc_actual_arglist** actual) { gcc_assert (e->expr_type == EXPR_COMPCALL); gcc_assert (!e->value.compcall.tbp->is_generic); /* Update the actual arglist for PASS. */ if (!update_compcall_arglist (e)) return false; *actual = e->value.compcall.actual; *target = e->value.compcall.tbp->u.specific; gfc_free_ref_list (e->ref); e->ref = NULL; e->value.compcall.actual = NULL; /* If we find a deferred typebound procedure, check for derived types that an overriding typebound procedure has not been missed. */ if (e->value.compcall.name && !e->value.compcall.tbp->non_overridable && e->value.compcall.base_object && e->value.compcall.base_object->ts.type == BT_DERIVED) { gfc_symtree *st; gfc_symbol *derived; /* Use the derived type of the base_object. */ derived = e->value.compcall.base_object->ts.u.derived; st = NULL; /* If necessary, go through the inheritance chain. */ while (!st && derived) { /* Look for the typebound procedure 'name'. */ if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, e->value.compcall.name); if (!st) derived = gfc_get_derived_super_type (derived); } /* Now find the specific name in the derived type namespace. */ if (st && st->n.tb && st->n.tb->u.specific) gfc_find_sym_tree (st->n.tb->u.specific->name, derived->ns, 1, &st); if (st) *target = st; } return true; } /* Get the ultimate declared type from an expression. In addition, return the last class/derived type reference and the copy of the reference list. If check_types is set true, derived types are identified as well as class references. */ static gfc_symbol* get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, gfc_expr *e, bool check_types) { gfc_symbol *declared; gfc_ref *ref; declared = NULL; if (class_ref) *class_ref = NULL; if (new_ref) *new_ref = gfc_copy_ref (e->ref); for (ref = e->ref; ref; ref = ref->next) { if (ref->type != REF_COMPONENT) continue; if ((ref->u.c.component->ts.type == BT_CLASS || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) && ref->u.c.component->attr.flavor != FL_PROCEDURE) { declared = ref->u.c.component->ts.u.derived; if (class_ref) *class_ref = ref; } } if (declared == NULL) declared = e->symtree->n.sym->ts.u.derived; return declared; } /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ static bool resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; gfc_symtree *st; gfc_symbol *derived; gcc_assert (e->expr_type == EXPR_COMPCALL); genname = e->value.compcall.name; genproc = e->value.compcall.tbp; if (!genproc->is_generic) return true; /* Try the bindings on this type and in the inheritance hierarchy. */ for (; genproc; genproc = genproc->overridden) { gfc_tbp_generic* g; gcc_assert (genproc->is_generic); for (g = genproc->u.generic; g; g = g->next) { gfc_symbol* target; gfc_actual_arglist* args; bool matches; gcc_assert (g->specific); if (g->specific->error) continue; target = g->specific->u.specific->n.sym; /* Get the right arglist by handling PASS/NOPASS. */ args = gfc_copy_actual_arglist (e->value.compcall.actual); if (!g->specific->nopass) { gfc_expr* po; po = extract_compcall_passed_object (e); if (!po) { gfc_free_actual_arglist (args); return false; } gcc_assert (g->specific->pass_arg_num > 0); gcc_assert (!g->specific->error); args = update_arglist_pass (args, po, g->specific->pass_arg_num, g->specific->pass_arg); } resolve_actual_arglist (args, target->attr.proc, is_external_proc (target) && gfc_sym_get_dummy_args (target) == NULL); /* Check if this arglist matches the formal. */ matches = gfc_arglist_matches_symbol (&args, target); /* Clean up and break out of the loop if we've found it. */ gfc_free_actual_arglist (args); if (matches) { e->value.compcall.tbp = g->specific; genname = g->specific_st->name; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) *name = genname; goto success; } } } /* Nothing matching found! */ gfc_error ("Found no matching specific binding for the call to the GENERIC" " %qs at %L", genname, &e->where); return false; success: /* Make sure that we have the right specific instance for the name. */ derived = get_declared_from_expr (NULL, NULL, e, true); st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); if (st) e->value.compcall.tbp = st->n.tb; return true; } /* Resolve a call to a type-bound subroutine. */ static bool resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a SUBROUTINE. */ if (!c->expr1->value.compcall.tbp->subroutine) { if (!c->expr1->value.compcall.tbp->is_generic && c->expr1->value.compcall.tbp->u.specific && c->expr1->value.compcall.tbp->u.specific->n.sym && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine) c->expr1->value.compcall.tbp->subroutine = 1; else { gfc_error ("%qs at %L should be a SUBROUTINE", c->expr1->value.compcall.name, &c->loc); return false; } } if (!check_typebound_baseobject (c->expr1)) return false; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) *name = c->expr1->value.compcall.name; if (!resolve_typebound_generic_call (c->expr1, name)) return false; /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */ if (overridable) *overridable = !c->expr1->value.compcall.tbp->non_overridable; /* Transform into an ordinary EXEC_CALL for now. */ if (!resolve_typebound_static (c->expr1, &target, &newactual)) return false; c->ext.actual = newactual; c->symtree = target; c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); gfc_free_expr (c->expr1); c->expr1 = gfc_get_expr (); c->expr1->expr_type = EXPR_FUNCTION; c->expr1->symtree = target; c->expr1->where = c->loc; return resolve_call (c); } /* Resolve a component-call expression. */ static bool resolve_compcall (gfc_expr* e, const char **name) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a FUNCTION. */ if (!e->value.compcall.tbp->function) { gfc_error ("%qs at %L should be a FUNCTION", e->value.compcall.name, &e->where); return false; } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); if (!check_typebound_baseobject (e)) return false; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) *name = e->value.compcall.name; if (!resolve_typebound_generic_call (e, name)) return false; gcc_assert (!e->value.compcall.tbp->is_generic); /* Take the rank from the function's symbol. */ if (e->value.compcall.tbp->u.specific->n.sym->as) e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank; /* For now, we simply transform it into an EXPR_FUNCTION call with the same arglist to the TBP's binding target. */ if (!resolve_typebound_static (e, &target, &newactual)) return false; e->value.function.actual = newactual; e->value.function.name = NULL; e->value.function.esym = target->n.sym; e->value.function.isym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; /* Resolution is not necessary if this is a class subroutine; this function only has to identify the specific proc. Resolution of the call will be done next in resolve_typebound_call. */ return gfc_resolve_expr (e); } static bool resolve_fl_derived (gfc_symbol *sym); /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ static bool resolve_typebound_function (gfc_expr* e) { gfc_symbol *declared; gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; const char *name; gfc_typespec ts; gfc_expr *expr; bool overridable; st = e->symtree; /* Deal with typebound operators for CLASS objects. */ expr = e->value.compcall.base_object; overridable = !e->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) { /* Since the typebound operators are generic, we have to ensure that any delays in resolution are corrected and that the vtab is present. */ ts = expr->ts; declared = ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); if (!resolve_compcall (e, &name)) return false; /* Use the generic name if it is there. */ name = name ? name : e->value.function.esym->name; e->symtree = expr->symtree; e->ref = gfc_copy_ref (expr->ref); get_declared_from_expr (&class_ref, NULL, e, false); /* Trim away the extraneous references that emerge from nested use of interface.c (extend_expr). */ if (class_ref && class_ref->next) { gfc_free_ref_list (class_ref->next); class_ref->next = NULL; } else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) { gfc_free_ref_list (e->ref); e->ref = NULL; } gfc_add_vptr_component (e); gfc_add_component_ref (e, name); e->value.function.esym = NULL; if (expr->expr_type != EXPR_VARIABLE) e->base_expr = expr; return true; } if (st == NULL) return resolve_compcall (e, NULL); if (!resolve_ref (e)) return false; /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e, true); if (!resolve_fl_derived (declared)) return false; /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); return resolve_compcall (e, NULL); } c = gfc_find_component (declared, "_data", true, true, NULL); /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ if (!resolve_compcall (e, &name)) { gfc_free_ref_list (new_ref); return false; } ts = e->ts; if (overridable) { /* Convert the expression to a procedure pointer component call. */ e->value.function.esym = NULL; e->symtree = st; if (new_ref) e->ref = new_ref; /* '_vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_vptr_component (e); gfc_add_component_ref (e, name); /* Recover the typespec for the expression. This is really only necessary for generic procedures, where the additional call to gfc_add_component_ref seems to throw the collection of the correct typespec. */ e->ts = ts; } else if (new_ref) gfc_free_ref_list (new_ref); return true; } /* Resolve a typebound subroutine, or 'method'. First separate all the non-CLASS references by calling resolve_typebound_call directly. */ static bool resolve_typebound_subroutine (gfc_code *code) { gfc_symbol *declared; gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; const char *name; gfc_typespec ts; gfc_expr *expr; bool overridable; st = code->expr1->symtree; /* Deal with typebound operators for CLASS objects. */ expr = code->expr1->value.compcall.base_object; overridable = !code->expr1->value.compcall.tbp->non_overridable; if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) { /* If the base_object is not a variable, the corresponding actual argument expression must be stored in e->base_expression so that the corresponding tree temporary can be used as the base object in gfc_conv_procedure_call. */ if (expr->expr_type != EXPR_VARIABLE) { gfc_actual_arglist *args; args= code->expr1->value.function.actual; for (; args; args = args->next) if (expr == args->expr) expr = args->expr; } /* Since the typebound operators are generic, we have to ensure that any delays in resolution are corrected and that the vtab is present. */ declared = expr->ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); if (!resolve_typebound_call (code, &name, NULL)) return false; /* Use the generic name if it is there. */ name = name ? name : code->expr1->value.function.esym->name; code->expr1->symtree = expr->symtree; code->expr1->ref = gfc_copy_ref (expr->ref); /* Trim away the extraneous references that emerge from nested use of interface.c (extend_expr). */ get_declared_from_expr (&class_ref, NULL, code->expr1, false); if (class_ref && class_ref->next) { gfc_free_ref_list (class_ref->next); class_ref->next = NULL; } else if (code->expr1->ref && !class_ref) { gfc_free_ref_list (code->expr1->ref); code->expr1->ref = NULL; } /* Now use the procedure in the vtable. */ gfc_add_vptr_component (code->expr1); gfc_add_component_ref (code->expr1, name); code->expr1->value.function.esym = NULL; if (expr->expr_type != EXPR_VARIABLE) code->expr1->base_expr = expr; return true; } if (st == NULL) return resolve_typebound_call (code, NULL, NULL); if (!resolve_ref (code->expr1)) return false; /* Get the CLASS declared type. */ get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); return resolve_typebound_call (code, NULL, NULL); } if (!resolve_typebound_call (code, &name, &overridable)) { gfc_free_ref_list (new_ref); return false; } ts = code->expr1->ts; if (overridable) { /* Convert the expression to a procedure pointer component call. */ code->expr1->value.function.esym = NULL; code->expr1->symtree = st; if (new_ref) code->expr1->ref = new_ref; /* '_vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_vptr_component (code->expr1); gfc_add_component_ref (code->expr1, name); /* Recover the typespec for the expression. This is really only necessary for generic procedures, where the additional call to gfc_add_component_ref seems to throw the collection of the correct typespec. */ code->expr1->ts = ts; } else if (new_ref) gfc_free_ref_list (new_ref); return true; } /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ static bool resolve_ppc_call (gfc_code* c) { gfc_component *comp; comp = gfc_get_proc_ptr_comp (c->expr1); gcc_assert (comp != NULL); c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; if (!comp->attr.subroutine) gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); if (!resolve_ref (c->expr1)) return false; if (!update_ppc_arglist (c->expr1)) return false; c->ext.actual = c->expr1->value.compcall.actual; if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, !(comp->ts.interface && comp->ts.interface->formal))) return false; if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) return false; gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); return true; } /* Resolve a Function Call to a Procedure Pointer Component (Function). */ static bool resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; comp = gfc_get_proc_ptr_comp (e); gcc_assert (comp != NULL); /* Convert to EXPR_FUNCTION. */ e->expr_type = EXPR_FUNCTION; e->value.function.isym = NULL; e->value.function.actual = e->value.compcall.actual; e->ts = comp->ts; if (comp->as != NULL) e->rank = comp->as->rank; if (!comp->attr.function) gfc_add_function (&comp->attr, comp->name, &e->where); if (!resolve_ref (e)) return false; if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, !(comp->ts.interface && comp->ts.interface->formal))) return false; if (!update_ppc_arglist (e)) return false; if (!check_pure_function(e)) return false; gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); return true; } static bool gfc_is_expandable_expr (gfc_expr *e) { gfc_constructor *con; if (e->expr_type == EXPR_ARRAY) { /* Traverse the constructor looking for variables that are flavor parameter. Parameters must be expanded since they are fully used at compile time. */ con = gfc_constructor_first (e->value.constructor); for (; con; con = gfc_constructor_next (con)) { if (con->expr->expr_type == EXPR_VARIABLE && con->expr->symtree && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) return true; if (con->expr->expr_type == EXPR_ARRAY && gfc_is_expandable_expr (con->expr)) return true; } } return false; } /* Sometimes variables in specification expressions of the result of module procedures in submodules wind up not being the 'real' dummy. Find this, if possible, in the namespace of the first formal argument. */ static void fixup_unique_dummy (gfc_expr *e) { gfc_symtree *st = NULL; gfc_symbol *s = NULL; if (e->symtree->n.sym->ns->proc_name && e->symtree->n.sym->ns->proc_name->formal) s = e->symtree->n.sym->ns->proc_name->formal->sym; if (s != NULL) st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name); if (st != NULL && st->n.sym != NULL && st->n.sym->attr.dummy) e->symtree = st; } /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ bool gfc_resolve_expr (gfc_expr *e) { bool t; bool inquiry_save, actual_arg_save, first_actual_arg_save; if (e == NULL || e->do_not_resolve_again) return true; /* inquiry_argument only applies to variables. */ inquiry_save = inquiry_argument; actual_arg_save = actual_arg; first_actual_arg_save = first_actual_arg; if (e->expr_type != EXPR_VARIABLE) { inquiry_argument = false; actual_arg = false; first_actual_arg = false; } else if (e->symtree != NULL && *e->symtree->name == '@' && e->symtree->n.sym->attr.dummy) { /* Deal with submodule specification expressions that are not found to be referenced in module.c(read_cleanup). */ fixup_unique_dummy (e); } switch (e->expr_type) { case EXPR_OP: t = resolve_operator (e); break; case EXPR_FUNCTION: case EXPR_VARIABLE: if (check_host_association (e)) t = resolve_function (e); else t = resolve_variable (e); if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref && e->ref->type != REF_SUBSTRING) gfc_resolve_substring_charlen (e); break; case EXPR_COMPCALL: t = resolve_typebound_function (e); break; case EXPR_SUBSTRING: t = resolve_ref (e); break; case EXPR_CONSTANT: case EXPR_NULL: t = true; break; case EXPR_PPC: t = resolve_expr_ppc (e); break; case EXPR_ARRAY: t = false; if (!resolve_ref (e)) break; t = gfc_resolve_array_constructor (e); /* Also try to expand a constructor. */ if (t) { expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) gfc_expand_constructor (e, false); } /* This provides the opportunity for the length of constructors with character valued function elements to propagate the string length to the expression. */ if (t && e->ts.type == BT_CHARACTER) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER here rather then add a duplicate test for it above. */ gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } break; case EXPR_STRUCTURE: t = resolve_ref (e); if (!t) break; t = resolve_structure_cons (e, 0); if (!t) break; t = gfc_simplify_expr (e, 0); break; default: gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); } if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) fixup_charlen (e); inquiry_argument = inquiry_save; actual_arg = actual_arg_save; first_actual_arg = first_actual_arg_save; /* For some reason, resolving these expressions a second time mangles the typespec of the expression itself. */ if (t && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.select_rank_temporary && UNLIMITED_POLY (e->symtree->n.sym)) e->do_not_resolve_again = 1; return t; } /* Resolve an expression from an iterator. They must be scalar and have INTEGER or (optionally) REAL type. */ static bool gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, const char *name_msgid) { if (!gfc_resolve_expr (expr)) return false; if (expr->rank != 0) { gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); return false; } if (expr->ts.type != BT_INTEGER) { if (expr->ts.type == BT_REAL) { if (real_ok) return gfc_notify_std (GFC_STD_F95_DEL, "%s at %L must be integer", _(name_msgid), &expr->where); else { gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); return false; } } else { gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); return false; } } return true; } /* Resolve the expressions in an iterator structure. If REAL_OK is false allow only INTEGER type iterators, otherwise allow REAL types. Set own_scope to true for ac-implied-do and data-implied-do as those have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */ bool gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) { if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) return false; if (!gfc_check_vardef_context (iter->var, false, false, own_scope, _("iterator variable"))) return false; if (!gfc_resolve_iterator_expr (iter->start, real_ok, "Start expression in DO loop")) return false; if (!gfc_resolve_iterator_expr (iter->end, real_ok, "End expression in DO loop")) return false; if (!gfc_resolve_iterator_expr (iter->step, real_ok, "Step expression in DO loop")) return false; /* Convert start, end, and step to the same type as var. */ if (iter->start->ts.kind != iter->var->ts.kind || iter->start->ts.type != iter->var->ts.type) gfc_convert_type (iter->start, &iter->var->ts, 1); if (iter->end->ts.kind != iter->var->ts.kind || iter->end->ts.type != iter->var->ts.type) gfc_convert_type (iter->end, &iter->var->ts, 1); if (iter->step->ts.kind != iter->var->ts.kind || iter->step->ts.type != iter->var->ts.type) gfc_convert_type (iter->step, &iter->var->ts, 1); if (iter->step->expr_type == EXPR_CONSTANT) { if ((iter->step->ts.type == BT_INTEGER && mpz_cmp_ui (iter->step->value.integer, 0) == 0) || (iter->step->ts.type == BT_REAL && mpfr_sgn (iter->step->value.real) == 0)) { gfc_error ("Step expression in DO loop at %L cannot be zero", &iter->step->where); return false; } } if (iter->start->expr_type == EXPR_CONSTANT && iter->end->expr_type == EXPR_CONSTANT && iter->step->expr_type == EXPR_CONSTANT) { int sgn, cmp; if (iter->start->ts.type == BT_INTEGER) { sgn = mpz_cmp_ui (iter->step->value.integer, 0); cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer); } else { sgn = mpfr_sgn (iter->step->value.real); cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real); } if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))) gfc_warning (OPT_Wzerotrip, "DO loop at %L will be executed zero times", &iter->step->where); } if (iter->end->expr_type == EXPR_CONSTANT && iter->end->ts.type == BT_INTEGER && iter->step->expr_type == EXPR_CONSTANT && iter->step->ts.type == BT_INTEGER && (mpz_cmp_si (iter->step->value.integer, -1L) == 0 || mpz_cmp_si (iter->step->value.integer, 1L) == 0)) { bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0; int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false); if (is_step_positive && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0) gfc_warning (OPT_Wundefined_do_loop, "DO loop at %L is undefined as it overflows", &iter->step->where); else if (!is_step_positive && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].min_int) == 0) gfc_warning (OPT_Wundefined_do_loop, "DO loop at %L is undefined as it underflows", &iter->step->where); } return true; } /* Traversal function for find_forall_index. f == 2 signals that that variable itself is not to be checked - only the references. */ static bool forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) { if (expr->expr_type != EXPR_VARIABLE) return false; /* A scalar assignment */ if (!expr->ref || *f == 1) { if (expr->symtree->n.sym == sym) return true; else return false; } if (*f == 2) *f = 1; return false; } /* Check whether the FORALL index appears in the expression or not. Returns true if SYM is found in EXPR. */ bool find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) { if (gfc_traverse_expr (expr, sym, forall_index, f)) return true; else return false; } /* Resolve a list of FORALL iterators. The FORALL index-name is constrained to be a scalar INTEGER variable. The subscripts and stride are scalar INTEGERs, and if stride is a constant it must be nonzero. Furthermore "A subscript or stride in a forall-triplet-spec shall not contain a reference to any index-name in the forall-triplet-spec-list in which it appears." (7.5.4.1) */ static void resolve_forall_iterators (gfc_forall_iterator *it) { gfc_forall_iterator *iter, *iter2; for (iter = it; iter; iter = iter->next) { if (gfc_resolve_expr (iter->var) && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) gfc_error ("FORALL index-name at %L must be a scalar INTEGER", &iter->var->where); if (gfc_resolve_expr (iter->start) && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) gfc_error ("FORALL start expression at %L must be a scalar INTEGER", &iter->start->where); if (iter->var->ts.kind != iter->start->ts.kind) gfc_convert_type (iter->start, &iter->var->ts, 1); if (gfc_resolve_expr (iter->end) && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) gfc_error ("FORALL end expression at %L must be a scalar INTEGER", &iter->end->where); if (iter->var->ts.kind != iter->end->ts.kind) gfc_convert_type (iter->end, &iter->var->ts, 1); if (gfc_resolve_expr (iter->stride)) { if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0) gfc_error ("FORALL stride expression at %L must be a scalar %s", &iter->stride->where, "INTEGER"); if (iter->stride->expr_type == EXPR_CONSTANT && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) gfc_error ("FORALL stride expression at %L cannot be zero", &iter->stride->where); } if (iter->var->ts.kind != iter->stride->ts.kind) gfc_convert_type (iter->stride, &iter->var->ts, 1); } for (iter = it; iter; iter = iter->next) for (iter2 = iter; iter2; iter2 = iter2->next) { if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0) || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0) || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0)) gfc_error ("FORALL index %qs may not appear in triplet " "specification at %L", iter->var->symtree->name, &iter2->start->where); } } /* Given a pointer to a symbol that is a derived type, see if it's inaccessible, i.e. if it's defined in another module and the components are PRIVATE. The search is recursive if necessary. Returns zero if no inaccessible components are found, nonzero otherwise. */ static int derived_inaccessible (gfc_symbol *sym) { gfc_component *c; if (sym->attr.use_assoc && sym->attr.private_comp) return 1; for (c = sym->components; c; c = c->next) { /* Prevent an infinite loop through this function. */ if (c->ts.type == BT_DERIVED && c->attr.pointer && sym == c->ts.u.derived) continue; if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) return 1; } return 0; } /* Resolve the argument of a deallocate expression. The expression must be a pointer or a full array. */ static bool resolve_deallocate_expr (gfc_expr *e) { symbol_attribute attr; int allocatable, pointer; gfc_ref *ref; gfc_symbol *sym; gfc_component *c; bool unlimited; if (!gfc_resolve_expr (e)) return false; if (e->expr_type != EXPR_VARIABLE) goto bad; sym = e->symtree->n.sym; unlimited = UNLIMITED_POLY(sym); if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; pointer = CLASS_DATA (sym)->attr.class_pointer; } else { allocatable = sym->attr.allocatable; pointer = sym->attr.pointer; } for (ref = e->ref; ref; ref = ref->next) { switch (ref->type) { case REF_ARRAY: if (ref->u.ar.type != AR_FULL && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 && ref->u.ar.codimen && gfc_ref_this_image (ref))) allocatable = 0; break; case REF_COMPONENT: c = ref->u.c.component; if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; pointer = CLASS_DATA (c)->attr.class_pointer; } else { allocatable = c->attr.allocatable; pointer = c->attr.pointer; } break; case REF_SUBSTRING: case REF_INQUIRY: allocatable = 0; break; } } attr = gfc_expr_attr (e); if (allocatable == 0 && attr.pointer == 0 && !unlimited) { bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); return false; } /* F2008, C644. */ if (gfc_is_coindexed (e)) { gfc_error ("Coindexed allocatable object at %L", &e->where); return false; } if (pointer && !gfc_check_vardef_context (e, true, true, false, _("DEALLOCATE object"))) return false; if (!gfc_check_vardef_context (e, false, true, false, _("DEALLOCATE object"))) return false; return true; } /* Returns true if the expression e contains a reference to the symbol sym. */ static bool sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym) return true; return false; } bool gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) { return gfc_traverse_expr (e, sym, sym_in_expr, 0); } /* Given the expression node e for an allocatable/pointer of derived type to be allocated, get the expression node to be initialized afterwards (needed for derived types with default initializers, and derived types with allocatable components that need nullification.) */ gfc_expr * gfc_expr_to_initialize (gfc_expr *e) { gfc_expr *result; gfc_ref *ref; int i; result = gfc_copy_expr (e); /* Change the last array reference from AR_ELEMENT to AR_FULL. */ for (ref = result->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->next == NULL) { if (ref->u.ar.dimen == 0 && ref->u.ar.as && ref->u.ar.as->corank) return result; ref->u.ar.type = AR_FULL; for (i = 0; i < ref->u.ar.dimen; i++) ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL; break; } gfc_free_shape (&result->shape, result->rank); /* Recalculate rank, shape, etc. */ gfc_resolve_expr (result); return result; } /* If the last ref of an expression is an array ref, return a copy of the expression with that one removed. Otherwise, a copy of the original expression. This is used for allocate-expressions and pointer assignment LHS, where there may be an array specification that needs to be stripped off when using gfc_check_vardef_context. */ static gfc_expr* remove_last_array_ref (gfc_expr* e) { gfc_expr* e2; gfc_ref** r; e2 = gfc_copy_expr (e); for (r = &e2->ref; *r; r = &(*r)->next) if ((*r)->type == REF_ARRAY && !(*r)->next) { gfc_free_ref_list (*r); *r = NULL; break; } return e2; } /* Used in resolve_allocate_expr to check that a allocation-object and a source-expr are conformable. This does not catch all possible cases; in particular a runtime checking is needed. */ static bool conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; for (tail = e2->ref; tail && tail->next; tail = tail->next); /* First compare rank. */ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) || (!tail && e1->rank != e2->rank)) { gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", &e1->where, &e2->where); return false; } if (e1->shape) { int i; mpz_t s; mpz_init (s); for (i = 0; i < e1->rank; i++) { if (tail->u.ar.start[i] == NULL) break; if (tail->u.ar.end[i]) { mpz_set (s, tail->u.ar.end[i]->value.integer); mpz_sub (s, s, tail->u.ar.start[i]->value.integer); mpz_add_ui (s, s, 1); } else { mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) { gfc_error ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); return false; } } mpz_clear (s); } return true; } /* Resolve the expression in an ALLOCATE statement, doing the additional checks to see whether the expression is OK or not. The expression must have a trailing array reference that gives the size of the array. */ static bool resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) { int i, pointer, allocatable, dimension, is_abstract; int codimension; bool coindexed; bool unlimited; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_expr *e2; gfc_array_ref *ar; gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; bool t; /* Mark the utmost array component as being in allocate to allow DIMEN_STAR checking of coarrays. */ for (ref = e->ref; ref; ref = ref->next) if (ref->next == NULL) break; if (ref && ref->type == REF_ARRAY) ref->u.ar.in_allocate = true; if (!gfc_resolve_expr (e)) goto failure; /* Make sure the expression is allocatable or a pointer. If it is pointer, the next-to-last reference must be a pointer. */ ref2 = NULL; if (e->symtree) sym = e->symtree->n.sym; /* Check whether ultimate component is abstract and CLASS. */ is_abstract = 0; /* Is the allocate-object unlimited polymorphic? */ unlimited = UNLIMITED_POLY(e); if (e->expr_type != EXPR_VARIABLE) { allocatable = 0; attr = gfc_expr_attr (e); pointer = attr.pointer; dimension = attr.dimension; codimension = attr.codimension; } else { if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) { allocatable = CLASS_DATA (sym)->attr.allocatable; pointer = CLASS_DATA (sym)->attr.class_pointer; dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; is_abstract = CLASS_DATA (sym)->attr.abstract; } else { allocatable = sym->attr.allocatable; pointer = sym->attr.pointer; dimension = sym->attr.dimension; codimension = sym->attr.codimension; } coindexed = false; for (ref = e->ref; ref; ref2 = ref, ref = ref->next) { switch (ref->type) { case REF_ARRAY: if (ref->u.ar.codimen > 0) { int n; for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) { coindexed = true; break; } } if (ref->next != NULL) pointer = 0; break; case REF_COMPONENT: /* F2008, C644. */ if (coindexed) { gfc_error ("Coindexed allocatable object at %L", &e->where); goto failure; } c = ref->u.c.component; if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; pointer = CLASS_DATA (c)->attr.class_pointer; dimension = CLASS_DATA (c)->attr.dimension; codimension = CLASS_DATA (c)->attr.codimension; is_abstract = CLASS_DATA (c)->attr.abstract; } else { allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; codimension = c->attr.codimension; is_abstract = c->attr.abstract; } break; case REF_SUBSTRING: case REF_INQUIRY: allocatable = 0; pointer = 0; break; } } } /* Check for F08:C628. */ if (allocatable == 0 && pointer == 0 && !unlimited) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); goto failure; } /* Some checks for the SOURCE tag. */ if (code->expr3) { /* Check F03:C631. */ if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &e->where, &code->expr3->where); goto failure; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) goto failure; /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind && !unlimited) { gfc_error ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); goto failure; } /* Check F2008, C642. */ if (code->expr3->ts.type == BT_DERIVED && ((codimension && gfc_expr_attr (code->expr3).lock_comp) || (code->expr3->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && code->expr3->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) { gfc_error ("The source-expr at %L shall neither be of type " "LOCK_TYPE nor have a LOCK_TYPE component if " "allocate-object at %L is a coarray", &code->expr3->where, &e->where); goto failure; } /* Check TS18508, C702/C703. */ if (code->expr3->ts.type == BT_DERIVED && ((codimension && gfc_expr_attr (code->expr3).event_comp) || (code->expr3->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && code->expr3->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) { gfc_error ("The source-expr at %L shall neither be of type " "EVENT_TYPE nor have a EVENT_TYPE component if " "allocate-object at %L is a coarray", &code->expr3->where, &e->where); goto failure; } } /* Check F08:C629. */ if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " "type-spec or source-expr", sym->name, &e->where); goto failure; } /* Check F08:C632. */ if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred && !UNLIMITED_POLY (e)) { int cmp; if (!e->ts.u.cl->length) goto failure; cmp = gfc_dep_compare_expr (e->ts.u.cl->length, code->ext.alloc.ts.u.cl->length); if (cmp == 1 || cmp == -1 || cmp == -3) { gfc_error ("Allocating %s at %L with type-spec requires the same " "character-length parameter as in the declaration", sym->name, &e->where); goto failure; } } /* In the variable definition context checks, gfc_expr_attr is used on the expression. This is fooled by the array specification present in e, thus we have to eliminate that one temporarily. */ e2 = remove_last_array_ref (e); t = true; if (t && pointer) t = gfc_check_vardef_context (e2, true, true, false, _("ALLOCATE object")); if (t) t = gfc_check_vardef_context (e2, false, true, false, _("ALLOCATE object")); gfc_free_expr (e2); if (!t) goto failure; if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) { /* For class arrays, the initialization with SOURCE is done using _copy and trans_call. It is convenient to exploit that when the allocated type is different from the declared type but no SOURCE exists by setting expr3. */ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); } else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) { /* We have to zero initialize the integer variable. */ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); } if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) { /* Make sure the vtab symbol is present when the module variables are generated. */ gfc_typespec ts = e->ts; if (code->expr3) ts = code->expr3->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; /* Finding the vtab also publishes the type's symbol. Therefore this statement is necessary. */ gfc_find_derived_vtab (ts.u.derived); } else if (unlimited && !UNLIMITED_POLY (code->expr3)) { /* Again, make sure the vtab symbol is present when the module variables are generated. */ gfc_typespec *ts = NULL; if (code->expr3) ts = &code->expr3->ts; else ts = &code->ext.alloc.ts; gcc_assert (ts); /* Finding the vtab also publishes the type's symbol. Therefore this statement is necessary. */ gfc_find_vtab (ts); } if (dimension == 0 && codimension == 0) goto success; /* Make sure the last reference node is an array specification. */ if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL || (dimension && ref2->u.ar.dimen == 0)) { /* F08:C633. */ if (code->expr3) { if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " "in ALLOCATE statement at %L", &e->where)) goto failure; if (code->expr3->rank != 0) *array_alloc_wo_spec = true; else { gfc_error ("Array specification or array-valued SOURCE= " "expression required in ALLOCATE statement at %L", &e->where); goto failure; } } else { gfc_error ("Array specification required in ALLOCATE statement " "at %L", &e->where); goto failure; } } /* Make sure that the array section reference makes sense in the context of an ALLOCATE specification. */ ar = &ref2->u.ar; if (codimension) for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) { switch (ar->dimen_type[i]) { case DIMEN_THIS_IMAGE: gfc_error ("Coarray specification required in ALLOCATE statement " "at %L", &e->where); goto failure; case DIMEN_RANGE: if (ar->start[i] == 0 || ar->end[i] == 0) { /* If ar->stride[i] is NULL, we issued a previous error. */ if (ar->stride[i] == NULL) gfc_error ("Bad array specification in ALLOCATE statement " "at %L", &e->where); goto failure; } else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1) { gfc_error ("Upper cobound is less than lower cobound at %L", &ar->start[i]->where); goto failure; } break; case DIMEN_ELEMENT: if (ar->start[i]->expr_type == EXPR_CONSTANT) { gcc_assert (ar->start[i]->ts.type == BT_INTEGER); if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0) { gfc_error ("Upper cobound is less than lower cobound " "of 1 at %L", &ar->start[i]->where); goto failure; } } break; case DIMEN_STAR: break; default: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); goto failure; } } for (i = 0; i < ar->dimen; i++) { if (ar->type == AR_ELEMENT || ar->type == AR_FULL) goto check_symbols; switch (ar->dimen_type[i]) { case DIMEN_ELEMENT: break; case DIMEN_RANGE: if (ar->start[i] != NULL && ar->end[i] != NULL && ar->stride[i] == NULL) break; /* Fall through. */ case DIMEN_UNKNOWN: case DIMEN_VECTOR: case DIMEN_STAR: case DIMEN_THIS_IMAGE: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); goto failure; } check_symbols: for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; /* TODO - check derived type components. */ if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) continue; if ((ar->start[i] != NULL && gfc_find_sym_in_expr (sym, ar->start[i])) || (ar->end[i] != NULL && gfc_find_sym_in_expr (sym, ar->end[i]))) { gfc_error ("%qs must not appear in the array specification at " "%L in the same ALLOCATE statement where it is " "itself allocated", sym->name, &ar->where); goto failure; } } } for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) { if (ar->dimen_type[i] == DIMEN_ELEMENT || ar->dimen_type[i] == DIMEN_RANGE) { if (i == (ar->dimen + ar->codimen - 1)) { gfc_error ("Expected '*' in coindex specification in ALLOCATE " "statement at %L", &e->where); goto failure; } continue; } if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) && ar->stride[i] == NULL) break; gfc_error ("Bad coarray specification in ALLOCATE statement at %L", &e->where); goto failure; } success: return true; failure: return false; } static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { gfc_expr *stat, *errmsg, *pe, *qe; gfc_alloc *a, *p, *q; stat = code->expr1; errmsg = code->expr2; /* Check the stat variable. */ if (stat) { gfc_check_vardef_context (stat, false, false, false, _("STAT variable")); if ((stat->ts.type != BT_INTEGER && !(stat->ref && (stat->ref->type == REF_ARRAY || stat->ref->type == REF_COMPONENT))) || stat->rank > 0) gfc_error ("Stat-variable at %L must be a scalar INTEGER " "variable", &stat->where); for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) { gfc_ref *ref1, *ref2; bool found = true; for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; ref1 = ref1->next, ref2 = ref2->next) { if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) continue; if (ref1->u.c.component->name != ref2->u.c.component->name) { found = false; break; } } if (found) { gfc_error ("Stat-variable at %L shall not be %sd within " "the same %s statement", &stat->where, fcn, fcn); break; } } } /* Check the errmsg variable. */ if (errmsg) { if (!stat) gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", &errmsg->where); gfc_check_vardef_context (errmsg, false, false, false, _("ERRMSG variable")); /* F18:R928 alloc-opt is ERRMSG = errmsg-variable F18:R930 errmsg-variable is scalar-default-char-variable F18:R906 default-char-variable is variable F18:C906 default-char-variable shall be default character. */ if ((errmsg->ts.type != BT_CHARACTER && !(errmsg->ref && (errmsg->ref->type == REF_ARRAY || errmsg->ref->type == REF_COMPONENT))) || errmsg->rank > 0 || errmsg->ts.kind != gfc_default_character_kind) gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER " "variable", &errmsg->where); for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) { gfc_ref *ref1, *ref2; bool found = true; for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; ref1 = ref1->next, ref2 = ref2->next) { if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) continue; if (ref1->u.c.component->name != ref2->u.c.component->name) { found = false; break; } } if (found) { gfc_error ("Errmsg-variable at %L shall not be %sd within " "the same %s statement", &errmsg->where, fcn, fcn); break; } } } /* Check that an allocate-object appears only once in the statement. */ for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; for (q = p->next; q; q = q->next) { qe = q->expr; if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) { /* This is a potential collision. */ gfc_ref *pr = pe->ref; gfc_ref *qr = qe->ref; /* Follow the references until a) They start to differ, in which case there is no error; you can deallocate a%b and a%c in a single statement b) Both of them stop, which is an error c) One of them stops, which is also an error. */ while (1) { if (pr == NULL && qr == NULL) { gfc_error ("Allocate-object at %L also appears at %L", &pe->where, &qe->where); break; } else if (pr != NULL && qr == NULL) { gfc_error ("Allocate-object at %L is subobject of" " object at %L", &pe->where, &qe->where); break; } else if (pr == NULL && qr != NULL) { gfc_error ("Allocate-object at %L is subobject of" " object at %L", &qe->where, &pe->where); break; } /* Here, pr != NULL && qr != NULL */ gcc_assert(pr->type == qr->type); if (pr->type == REF_ARRAY) { /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), which are legal. */ gcc_assert (qr->type == REF_ARRAY); if (pr->next && qr->next) { int i; gfc_array_ref *par = &(pr->u.ar); gfc_array_ref *qar = &(qr->u.ar); for (i=0; i<par->dimen; i++) { if ((par->start[i] != NULL || qar->start[i] != NULL) && gfc_dep_compare_expr (par->start[i], qar->start[i]) != 0) goto break_label; } } } else { if (pr->u.c.component->name != qr->u.c.component->name) break; } pr = pr->next; qr = qr->next; } break_label: ; } } } if (strcmp (fcn, "ALLOCATE") == 0) { bool arr_alloc_wo_spec = false; /* Resolving the expr3 in the loop over all objects to allocate would execute loop invariant code for each loop item. Therefore do it just once here. */ if (code->expr3 && code->expr3->mold && code->expr3->ts.type == BT_DERIVED) { /* Default initialization via MOLD (non-polymorphic). */ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); if (rhs != NULL) { gfc_resolve_expr (rhs); gfc_free_expr (code->expr3); code->expr3 = rhs; } } for (a = code->ext.alloc.list; a; a = a->next) resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); if (arr_alloc_wo_spec && code->expr3) { /* Mark the allocate to have to take the array specification from the expr3. */ code->ext.alloc.arr_spec_from_expr3 = 1; } } else { for (a = code->ext.alloc.list; a; a = a->next) resolve_deallocate_expr (a->expr); } } /************ SELECT CASE resolution subroutines ************/ /* Callback function for our mergesort variant. Determines interval overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for op1 > op2. Assumes we're not dealing with the default case. We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). There are nine situations to check. */ static int compare_cases (const gfc_case *op1, const gfc_case *op2) { int retval; if (op1->low == NULL) /* op1 = (:L) */ { /* op2 = (:N), so overlap. */ retval = 0; /* op2 = (M:) or (M:N), L < M */ if (op2->low != NULL && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) retval = -1; } else if (op1->high == NULL) /* op1 = (K:) */ { /* op2 = (M:), so overlap. */ retval = 0; /* op2 = (:N) or (M:N), K > N */ if (op2->high != NULL && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) retval = 1; } else /* op1 = (K:L) */ { if (op2->low == NULL) /* op2 = (:N), K > N */ retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) ? 1 : 0; else if (op2->high == NULL) /* op2 = (M:), L < M */ retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) ? -1 : 0; else /* op2 = (M:N) */ { retval = 0; /* L < M */ if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) retval = -1; /* K > N */ else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) retval = 1; } } return retval; } /* Merge-sort a double linked case list, detecting overlap in the process. LIST is the head of the double linked case list before it is sorted. Returns the head of the sorted list if we don't see any overlap, or NULL otherwise. */ static gfc_case * check_case_overlap (gfc_case *list) { gfc_case *p, *q, *e, *tail; int insize, nmerges, psize, qsize, cmp, overlap_seen; /* If the passed list was empty, return immediately. */ if (!list) return NULL; overlap_seen = 0; insize = 1; /* Loop unconditionally. The only exit from this loop is a return statement, when we've finished sorting the case list. */ for (;;) { p = list; list = NULL; tail = NULL; /* Count the number of merges we do in this pass. */ nmerges = 0; /* Loop while there exists a merge to be done. */ while (p) { int i; /* Count this merge. */ nmerges++; /* Cut the list in two pieces by stepping INSIZE places forward in the list, starting from P. */ psize = 0; q = p; for (i = 0; i < insize; i++) { psize++; q = q->right; if (!q) break; } qsize = insize; /* Now we have two lists. Merge them! */ while (psize > 0 || (qsize > 0 && q != NULL)) { /* See from which the next case to merge comes from. */ if (psize == 0) { /* P is empty so the next case must come from Q. */ e = q; q = q->right; qsize--; } else if (qsize == 0 || q == NULL) { /* Q is empty. */ e = p; p = p->right; psize--; } else { cmp = compare_cases (p, q); if (cmp < 0) { /* The whole case range for P is less than the one for Q. */ e = p; p = p->right; psize--; } else if (cmp > 0) { /* The whole case range for Q is greater than the case range for P. */ e = q; q = q->right; qsize--; } else { /* The cases overlap, or they are the same element in the list. Either way, we must issue an error and get the next case from P. */ /* FIXME: Sort P and Q by line number. */ gfc_error ("CASE label at %L overlaps with CASE " "label at %L", &p->where, &q->where); overlap_seen = 1; e = p; p = p->right; psize--; } } /* Add the next element to the merged list. */ if (tail) tail->right = e; else list = e; e->left = tail; tail = e; } /* P has now stepped INSIZE places along, and so has Q. So they're the same. */ p = q; } tail->right = NULL; /* If we have done only one merge or none at all, we've finished sorting the cases. */ if (nmerges <= 1) { if (!overlap_seen) return list; else return NULL; } /* Otherwise repeat, merging lists twice the size. */ insize *= 2; } } /* Check to see if an expression is suitable for use in a CASE statement. Makes sure that all case expressions are scalar constants of the same type. Return false if anything is wrong. */ static bool validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) { if (e == NULL) return true; if (e->ts.type != case_expr->ts.type) { gfc_error ("Expression in CASE statement at %L must be of type %s", &e->where, gfc_basic_typename (case_expr->ts.type)); return false; } /* C805 (R808) For a given case-construct, each case-value shall be of the same type as case-expr. For character type, length differences are allowed, but the kind type parameters shall be the same. */ if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind) { gfc_error ("Expression in CASE statement at %L must be of kind %d", &e->where, case_expr->ts.kind); return false; } /* Convert the case value kind to that of case expression kind, if needed */ if (e->ts.kind != case_expr->ts.kind) gfc_convert_type_warn (e, &case_expr->ts, 2, 0); if (e->rank != 0) { gfc_error ("Expression in CASE statement at %L must be scalar", &e->where); return false; } return true; } /* Given a completely parsed select statement, we: - Validate all expressions and code within the SELECT. - Make sure that the selection expression is not of the wrong type. - Make sure that no case ranges overlap. - Eliminate unreachable cases and unreachable code resulting from removing case labels. The standard does allow unreachable cases, e.g. CASE (5:3). But they are a hassle for code generation, and to prevent that, we just cut them out here. This is not necessary for overlapping cases because they are illegal and we never even try to generate code. We have the additional caveat that a SELECT construct could have been a computed GOTO in the source code. Fortunately we can fairly easily work around that here: The case_expr for a "real" SELECT CASE is in code->expr1, but for a computed GOTO it is in code->expr2. All we have to do is make sure that the case_expr is a scalar integer expression. */ static void resolve_select (gfc_code *code, bool select_type) { gfc_code *body; gfc_expr *case_expr; gfc_case *cp, *default_case, *tail, *head; int seen_unreachable; int seen_logical; int ncases; bt type; bool t; if (code->expr1 == NULL) { /* This was actually a computed GOTO statement. */ case_expr = code->expr2; if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0) gfc_error ("Selection expression in computed GOTO statement " "at %L must be a scalar integer expression", &case_expr->where); /* Further checking is not necessary because this SELECT was built by the compiler, so it should always be OK. Just move the case_expr from expr2 to expr so that we can handle computed GOTOs as normal SELECTs from here on. */ code->expr1 = code->expr2; code->expr2 = NULL; return; } case_expr = code->expr1; type = case_expr->ts.type; /* F08:C830. */ if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) { gfc_error ("Argument of SELECT statement at %L cannot be %s", &case_expr->where, gfc_typename (case_expr)); /* Punt. Going on here just produce more garbage error messages. */ return; } /* F08:R842. */ if (!select_type && case_expr->rank != 0) { gfc_error ("Argument of SELECT statement at %L must be a scalar " "expression", &case_expr->where); /* Punt. */ return; } /* Raise a warning if an INTEGER case value exceeds the range of the case-expr. Later, all expressions will be promoted to the largest kind of all case-labels. */ if (type == BT_INTEGER) for (body = code->block; body; body = body->block) for (cp = body->ext.block.case_list; cp; cp = cp->next) { if (cp->low && gfc_check_integer_range (cp->low->value.integer, case_expr->ts.kind) != ARITH_OK) gfc_warning (0, "Expression in CASE statement at %L is " "not in the range of %s", &cp->low->where, gfc_typename (case_expr)); if (cp->high && cp->low != cp->high && gfc_check_integer_range (cp->high->value.integer, case_expr->ts.kind) != ARITH_OK) gfc_warning (0, "Expression in CASE statement at %L is " "not in the range of %s", &cp->high->where, gfc_typename (case_expr)); } /* PR 19168 has a long discussion concerning a mismatch of the kinds of the SELECT CASE expression and its CASE values. Walk the lists of case values, and if we find a mismatch, promote case_expr to the appropriate kind. */ if (type == BT_LOGICAL || type == BT_INTEGER) { for (body = code->block; body; body = body->block) { /* Walk the case label list. */ for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Intercept the DEFAULT case. It does not have a kind. */ if (cp->low == NULL && cp->high == NULL) continue; /* Unreachable case ranges are discarded, so ignore. */ if (cp->low != NULL && cp->high != NULL && cp->low != cp->high && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) continue; if (cp->low != NULL && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0); if (cp->high != NULL && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high)) gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0); } } } /* Assume there is no DEFAULT case. */ default_case = NULL; head = tail = NULL; ncases = 0; seen_logical = 0; for (body = code->block; body; body = body->block) { /* Assume the CASE list is OK, and all CASE labels can be matched. */ t = true; seen_unreachable = 0; /* Walk the case label list, making sure that all case labels are legal. */ for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Count the number of cases in the whole construct. */ ncases++; /* Intercept the DEFAULT case. */ if (cp->low == NULL && cp->high == NULL) { if (default_case != NULL) { gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); t = false; break; } else { default_case = cp; continue; } } /* Deal with single value cases and case ranges. Errors are issued from the validation function. */ if (!validate_case_label_expr (cp->low, case_expr) || !validate_case_label_expr (cp->high, case_expr)) { t = false; break; } if (type == BT_LOGICAL && ((cp->low == NULL || cp->high == NULL) || cp->low != cp->high)) { gfc_error ("Logical range in CASE statement at %L is not " "allowed", &cp->low->where); t = false; break; } if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) { int value; value = cp->low->value.logical == 0 ? 2 : 1; if (value & seen_logical) { gfc_error ("Constant logical value in CASE statement " "is repeated at %L", &cp->low->where); t = false; break; } seen_logical |= value; } if (cp->low != NULL && cp->high != NULL && cp->low != cp->high && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) { if (warn_surprising) gfc_warning (OPT_Wsurprising, "Range specification at %L can never be matched", &cp->where); cp->unreachable = 1; seen_unreachable = 1; } else { /* If the case range can be matched, it can also overlap with other cases. To make sure it does not, we put it in a double linked list here. We sort that with a merge sort later on to detect any overlapping cases. */ if (!head) { head = tail = cp; head->right = head->left = NULL; } else { tail->right = cp; tail->right->left = tail; tail = tail->right; tail->right = NULL; } } } /* It there was a failure in the previous case label, give up for this case label list. Continue with the next block. */ if (!t) continue; /* See if any case labels that are unreachable have been seen. If so, we eliminate them. This is a bit of a kludge because the case lists for a single case statement (label) is a single forward linked lists. */ if (seen_unreachable) { /* Advance until the first case in the list is reachable. */ while (body->ext.block.case_list != NULL && body->ext.block.case_list->unreachable) { gfc_case *n = body->ext.block.case_list; body->ext.block.case_list = body->ext.block.case_list->next; n->next = NULL; gfc_free_case_list (n); } /* Strip all other unreachable cases. */ if (body->ext.block.case_list) { for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next) { if (cp->next->unreachable) { gfc_case *n = cp->next; cp->next = cp->next->next; n->next = NULL; gfc_free_case_list (n); } } } } } /* See if there were overlapping cases. If the check returns NULL, there was overlap. In that case we don't do anything. If head is non-NULL, we prepend the DEFAULT case. The sorted list can then used during code generation for SELECT CASE constructs with a case expression of a CHARACTER type. */ if (head) { head = check_case_overlap (head); /* Prepend the default_case if it is there. */ if (head != NULL && default_case) { default_case->left = NULL; default_case->right = head; head->left = default_case; } } /* Eliminate dead blocks that may be the result if we've seen unreachable case labels for a block. */ for (body = code; body && body->block; body = body->block) { if (body->block->ext.block.case_list == NULL) { /* Cut the unreachable block from the code chain. */ gfc_code *c = body->block; body->block = c->block; /* Kill the dead block, but not the blocks below it. */ c->block = NULL; gfc_free_statements (c); } } /* More than two cases is legal but insane for logical selects. Issue a warning for it. */ if (warn_surprising && type == BT_LOGICAL && ncases > 2) gfc_warning (OPT_Wsurprising, "Logical SELECT CASE block at %L has more that two cases", &code->loc); } /* Check if a derived type is extensible. */ bool gfc_type_is_extensible (gfc_symbol *sym) { return !(sym->attr.is_bind_c || sym->attr.sequence || (sym->attr.is_class && sym->components->ts.u.derived->attr.unlimited_polymorphic)); } static void resolve_types (gfc_namespace *ns); /* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ static void resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { gfc_expr* target; gcc_assert (sym->assoc); gcc_assert (sym->attr.flavor == FL_VARIABLE); /* If this is for SELECT TYPE, the target may not yet be set. In that case, return. Resolution will be called later manually again when this is done. */ target = sym->assoc->target; if (!target) return; gcc_assert (!sym->assoc->dangling); if (resolve_target && !gfc_resolve_expr (target)) return; /* For variable targets, we get some attributes from the target. */ if (target->expr_type == EXPR_VARIABLE) { gfc_symbol* tsym; gcc_assert (target->symtree); tsym = target->symtree->n.sym; sym->attr.asynchronous = tsym->attr.asynchronous; sym->attr.volatile_ = tsym->attr.volatile_; sym->attr.target = tsym->attr.target || gfc_expr_attr (target).pointer; if (is_subref_array (target)) sym->attr.subref_array_pointer = 1; } if (target->expr_type == EXPR_NULL) { gfc_error ("Selector at %L cannot be NULL()", &target->where); return; } else if (target->ts.type == BT_UNKNOWN) { gfc_error ("Selector at %L has no type", &target->where); return; } /* Get type if this was not already set. Note that it can be some other type than the target in case this is a SELECT TYPE selector! So we must not update when the type is already there. */ if (sym->ts.type == BT_UNKNOWN) sym->ts = target->ts; gcc_assert (sym->ts.type != BT_UNKNOWN); /* See if this is a valid association-to-variable. */ sym->assoc->variable = (target->expr_type == EXPR_VARIABLE && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ if (sym->attr.dimension && target->rank == 0) { /* primary.c makes the assumption that a reference to an associate name followed by a left parenthesis is an array reference. */ if (sym->ts.type != BT_CHARACTER) gfc_error ("Associate-name %qs at %L is used as array", sym->name, &sym->declared_at); sym->attr.dimension = 0; return; } /* We cannot deal with class selectors that need temporaries. */ if (target->ts.type == BT_CLASS && gfc_ref_needs_temporary_p (target->ref)) { gfc_error ("CLASS selector at %L needs a temporary which is not " "yet implemented", &target->where); return; } if (target->ts.type == BT_CLASS) gfc_fix_class_refs (target); if (target->rank != 0 && !sym->attr.select_rank_temporary) { gfc_array_spec *as; /* The rank may be incorrectly guessed at parsing, therefore make sure it is corrected now. */ if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) { if (!sym->as) sym->as = gfc_get_array_spec (); as = sym->as; as->rank = target->rank; as->type = AS_DEFERRED; as->corank = gfc_get_corank (target); sym->attr.dimension = 1; if (as->corank != 0) sym->attr.codimension = 1; } else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) { if (!CLASS_DATA (sym)->as) CLASS_DATA (sym)->as = gfc_get_array_spec (); as = CLASS_DATA (sym)->as; as->rank = target->rank; as->type = AS_DEFERRED; as->corank = gfc_get_corank (target); CLASS_DATA (sym)->attr.dimension = 1; if (as->corank != 0) CLASS_DATA (sym)->attr.codimension = 1; } } else if (!sym->attr.select_rank_temporary) { /* target's rank is 0, but the type of the sym is still array valued, which has to be corrected. */ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && CLASS_DATA (sym)->as) { gfc_array_spec *as; symbol_attribute attr; /* The associated variable's type is still the array type correct this now. */ gfc_typespec *ts = &target->ts; gfc_ref *ref; gfc_component *c; for (ref = target->ref; ref != NULL; ref = ref->next) { switch (ref->type) { case REF_COMPONENT: ts = &ref->u.c.component->ts; break; case REF_ARRAY: if (ts->type == BT_CLASS) ts = &ts->u.derived->components->ts; break; default: break; } } /* Create a scalar instance of the current class type. Because the rank of a class array goes into its name, the type has to be rebuild. The alternative of (re-)setting just the attributes and as in the current type, destroys the type also in other places. */ as = NULL; sym->ts = *ts; sym->ts.type = BT_CLASS; attr = CLASS_DATA (sym)->attr; attr.class_ok = 0; attr.associate_var = 1; attr.dimension = attr.codimension = 0; attr.class_pointer = 1; if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) gcc_unreachable (); /* Make sure the _vptr is set. */ c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); CLASS_DATA (sym)->attr.pointer = 1; CLASS_DATA (sym)->attr.class_pointer = 1; gfc_set_sym_referenced (sym->ts.u.derived); gfc_commit_symbol (sym->ts.u.derived); /* _vptr now has the _vtab in it, change it to the _vtype. */ if (c->ts.u.derived->attr.vtab) c->ts.u.derived = c->ts.u.derived->ts.u.derived; c->ts.u.derived->ns->types_resolved = 0; resolve_types (c->ts.u.derived->ns); } } /* Mark this as an associate variable. */ sym->attr.associate_var = 1; /* Fix up the type-spec for CHARACTER types. */ if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary) { if (!sym->ts.u.cl) sym->ts.u.cl = target->ts.u.cl; if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE && target->symtree->n.sym->attr.dummy && sym->ts.u.cl == target->ts.u.cl) { sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); sym->ts.deferred = 1; } if (!sym->ts.u.cl->length && !sym->ts.deferred && target->expr_type == EXPR_CONSTANT) { sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, target->value.character.length); } else if ((!sym->ts.u.cl->length || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) && target->expr_type != EXPR_VARIABLE) { sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); sym->ts.deferred = 1; /* This is reset in trans-stmt.c after the assignment of the target expression to the associate name. */ sym->attr.allocatable = 1; } } /* If the target is a good class object, so is the associate variable. */ if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) sym->attr.class_ok = 1; } /* Ensure that SELECT TYPE expressions have the correct rank and a full array reference, where necessary. The symbols are artificial and so the dimension attribute and arrayspec can also be set. In addition, sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS. This is corrected here as well.*/ static void fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, int rank, gfc_ref *ref) { gfc_ref *nref = (*expr1)->ref; gfc_symbol *sym1 = (*expr1)->symtree->n.sym; gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; (*expr1)->rank = rank; if (sym1->ts.type == BT_CLASS) { if ((*expr1)->ts.type != BT_CLASS) (*expr1)->ts = sym1->ts; CLASS_DATA (sym1)->attr.dimension = 1; if (CLASS_DATA (sym1)->as == NULL && sym2) CLASS_DATA (sym1)->as = gfc_copy_array_spec (CLASS_DATA (sym2)->as); } else { sym1->attr.dimension = 1; if (sym1->as == NULL && sym2) sym1->as = gfc_copy_array_spec (sym2->as); } for (; nref; nref = nref->next) if (nref->next == NULL) break; if (ref && nref && nref->type != REF_ARRAY) nref->next = gfc_copy_ref (ref); else if (ref && !nref) (*expr1)->ref = gfc_copy_ref (ref); } static gfc_expr * build_loc_call (gfc_expr *sym_expr) { gfc_expr *loc_call; loc_call = gfc_get_expr (); loc_call->expr_type = EXPR_FUNCTION; gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false); loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE; loc_call->symtree->n.sym->attr.intrinsic = 1; loc_call->symtree->n.sym->result = loc_call->symtree->n.sym; gfc_commit_symbol (loc_call->symtree->n.sym); loc_call->ts.type = BT_INTEGER; loc_call->ts.kind = gfc_index_integer_kind; loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC); loc_call->value.function.actual = gfc_get_actual_arglist (); loc_call->value.function.actual->expr = sym_expr; loc_call->where = sym_expr->where; return loc_call; } /* Resolve a SELECT TYPE statement. */ static void resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { gfc_symbol *selector_type; gfc_code *body, *new_st, *if_st, *tail; gfc_code *class_is = NULL, *default_case = NULL; gfc_case *c; gfc_symtree *st; char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; int error = 0; int rank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; ns = code->ext.block.ns; gfc_resolve (ns); /* Check for F03:C813. */ if (code->expr1->ts.type != BT_CLASS && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) { gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " "at %L", &code->loc); return; } if (!code->expr1->symtree->n.sym->attr.class_ok) return; if (code->expr2) { gfc_ref *ref2 = NULL; for (ref = code->expr2->ref; ref != NULL; ref = ref->next) if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS) ref2 = ref; if (ref2) { if (code->expr1->symtree->n.sym->attr.untyped) code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts; selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived; } else { if (code->expr1->symtree->n.sym->attr.untyped) code->expr1->symtree->n.sym->ts = code->expr2->ts; selector_type = CLASS_DATA (code->expr2)->ts.u.derived; } if (code->expr2->rank && CLASS_DATA (code->expr1)->as) CLASS_DATA (code->expr1)->as->rank = code->expr2->rank; /* F2008: C803 The selector expression must not be coindexed. */ if (gfc_is_coindexed (code->expr2)) { gfc_error ("Selector at %L must not be coindexed", &code->expr2->where); return; } } else { selector_type = CLASS_DATA (code->expr1)->ts.u.derived; if (gfc_is_coindexed (code->expr1)) { gfc_error ("Selector at %L must not be coindexed", &code->expr1->where); return; } } /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { c = body->ext.block.case_list; if (!error) { /* Check for repeated cases. */ for (tail = code->block; tail; tail = tail->block) { gfc_case *d = tail->ext.block.case_list; if (tail == body) break; if (c->ts.type == d->ts.type && ((c->ts.type == BT_DERIVED && c->ts.u.derived && d->ts.u.derived && !strcmp (c->ts.u.derived->name, d->ts.u.derived->name)) || c->ts.type == BT_UNKNOWN || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) && c->ts.kind == d->ts.kind))) { gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L", &c->where, &d->where); return; } } } /* Check F03:C815. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) && !selector_type->attr.unlimited_polymorphic && !gfc_type_is_extensible (c->ts.u.derived)) { gfc_error ("Derived type %qs at %L must be extensible", c->ts.u.derived->name, &c->where); error++; continue; } /* Check F03:C816. */ if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) || !gfc_type_is_extension_of (selector_type, c->ts.u.derived))) { if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) gfc_error ("Derived type %qs at %L must be an extension of %qs", c->ts.u.derived->name, &c->where, selector_type->name); else gfc_error ("Unexpected intrinsic type %qs at %L", gfc_basic_typename (c->ts.type), &c->where); error++; continue; } /* Check F03:C814. */ if (c->ts.type == BT_CHARACTER && (c->ts.u.cl->length != NULL || c->ts.deferred)) { gfc_error ("The type-spec at %L shall specify that each length " "type parameter is assumed", &c->where); error++; continue; } /* Intercept the DEFAULT case. */ if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ if (default_case) { gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->ext.block.case_list->where, &c->where); error++; continue; } default_case = body; } } if (error > 0) return; /* Transform SELECT TYPE statement to BLOCK and associate selector to target if present. If there are any EXIT statements referring to the SELECT TYPE construct, this is no problem because the gfc_code reference stays the same and EXIT is equally possible from the BLOCK it is changed to. */ code->op = EXEC_BLOCK; if (code->expr2) { gfc_association_list* assoc; assoc = gfc_get_association_list (); assoc->st = code->expr1->symtree; assoc->target = gfc_copy_expr (code->expr2); assoc->target->where = code->expr2->where; /* assoc->variable will be set by resolve_assoc_var. */ code->ext.block.assoc = assoc; code->expr1->symtree->n.sym->assoc = assoc; resolve_assoc_var (code->expr1->symtree->n.sym, false); } else code->ext.block.assoc = NULL; /* Ensure that the selector rank and arrayspec are available to correct expressions in which they might be missing. */ if (code->expr2 && code->expr2->rank) { rank = code->expr2->rank; for (ref = code->expr2->ref; ref; ref = ref->next) if (ref->next == NULL) break; if (ref && ref->type == REF_ARRAY) ref = gfc_copy_ref (ref); /* Fixup expr1 if necessary. */ if (rank) fixup_array_ref (&code->expr1, code->expr2, rank, ref); } else if (code->expr1->rank) { rank = code->expr1->rank; for (ref = code->expr1->ref; ref; ref = ref->next) if (ref->next == NULL) break; if (ref && ref->type == REF_ARRAY) ref = gfc_copy_ref (ref); } /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; new_st->expr2 = code->expr2; new_st->block = code->block; code->expr1 = code->expr2 = NULL; code->block = NULL; if (!ns->code) ns->code = new_st; else ns->code->next = new_st; code = new_st; code->op = EXEC_SELECT_TYPE; /* Use the intrinsic LOC function to generate an integer expression for the vtable of the selector. Note that the rank of the selector expression has to be set to zero. */ gfc_add_vptr_component (code->expr1); code->expr1->rank = 0; code->expr1 = build_loc_call (code->expr1); selector_expr = code->expr1->value.function.actual->expr; /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { gfc_symbol *vtab; gfc_expr *e; c = body->ext.block.case_list; /* Generate an index integer expression for address of the TYPE/CLASS vtable and store it in c->low. The hash expression is stored in c->high and is used to resolve intrinsic cases. */ if (c->ts.type != BT_UNKNOWN) { if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) { vtab = gfc_find_derived_vtab (c->ts.u.derived); gcc_assert (vtab); c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL, c->ts.u.derived->hash_value); } else { vtab = gfc_find_vtab (&c->ts); gcc_assert (vtab && CLASS_DATA (vtab)->initializer); e = CLASS_DATA (vtab)->initializer; c->high = gfc_copy_expr (e); if (c->high->ts.kind != gfc_integer_4_kind) { gfc_typespec ts; ts.kind = gfc_integer_4_kind; ts.type = BT_INTEGER; gfc_convert_type_warn (c->high, &ts, 2, 0); } } e = gfc_lval_expr_from_sym (vtab); c->low = build_loc_call (e); } else continue; /* Associate temporary to selector. This should only be done when this case is actually true, so build a new ASSOCIATE that does precisely this here (instead of using the 'global' one). */ if (c->ts.type == BT_CLASS) sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); else if (c->ts.type == BT_DERIVED) sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); else if (c->ts.type == BT_CHARACTER) { HOST_WIDE_INT charlen = 0; if (c->ts.u.cl && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", gfc_basic_typename (c->ts.type), charlen, c->ts.kind); } else sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); st->n.sym->assoc->target->where = selector_expr->where; if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) { gfc_add_data_component (st->n.sym->assoc->target); /* Fixup the target expression if necessary. */ if (rank) fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref); } new_st = gfc_get_code (EXEC_BLOCK); new_st->ext.block.ns = gfc_build_block_ns (ns); new_st->ext.block.ns->code = body->next; body->next = new_st; /* Chain in the new list only if it is marked as dangling. Otherwise there is a CASE label overlap and this is already used. Just ignore, the error is diagnosed elsewhere. */ if (st->n.sym->assoc->dangling) { new_st->ext.block.assoc = st->n.sym->assoc; st->n.sym->assoc->dangling = 0; } resolve_assoc_var (st->n.sym, false); } /* Take out CLASS IS cases for separate treatment. */ body = code; while (body && body->block) { if (body->block->ext.block.case_list->ts.type == BT_CLASS) { /* Add to class_is list. */ if (class_is == NULL) { class_is = body->block; tail = class_is; } else { for (tail = class_is; tail->block; tail = tail->block) ; tail->block = body->block; tail = tail->block; } /* Remove from EXEC_SELECT list. */ body->block = body->block->block; tail->block = NULL; } else body = body->block; } if (class_is) { gfc_symbol *vtab; if (!default_case) { /* Add a default case to hold the CLASS IS cases. */ for (tail = code; tail->block; tail = tail->block) ; tail->block = gfc_get_code (EXEC_SELECT_TYPE); tail = tail->block; tail->ext.block.case_list = gfc_get_case (); tail->ext.block.case_list->ts.type = BT_UNKNOWN; tail->next = NULL; default_case = tail; } /* More than one CLASS IS block? */ if (class_is->block) { gfc_code **c1,*c2; bool swapped; /* Sort CLASS IS blocks by extension level. */ do { swapped = false; for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) { c2 = (*c1)->block; /* F03:C817 (check for doubles). */ if ((*c1)->ext.block.case_list->ts.u.derived->hash_value == c2->ext.block.case_list->ts.u.derived->hash_value) { gfc_error ("Double CLASS IS block in SELECT TYPE " "statement at %L", &c2->ext.block.case_list->where); return; } if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension < c2->ext.block.case_list->ts.u.derived->attr.extension) { /* Swap. */ (*c1)->block = c2->block; c2->block = *c1; *c1 = c2; swapped = true; } } } while (swapped); } /* Generate IF chain. */ if_st = gfc_get_code (EXEC_IF); new_st = if_st; for (body = class_is; body; body = body->block) { new_st->block = gfc_get_code (EXEC_IF); new_st = new_st->block; /* Set up IF condition: Call _gfortran_is_extension_of. */ new_st->expr1 = gfc_get_expr (); new_st->expr1->expr_type = EXPR_FUNCTION; new_st->expr1->ts.type = BT_LOGICAL; new_st->expr1->ts.kind = 4; new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; /* Set up arguments. */ new_st->expr1->value.function.actual = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree); new_st->expr1->value.function.actual->expr->where = code->loc; new_st->expr1->where = code->loc; gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); new_st->expr1->value.function.actual->next->expr->where = code->loc; new_st->next = body->next; } if (default_case->next) { new_st->block = gfc_get_code (EXEC_IF); new_st = new_st->block; new_st->next = default_case->next; } /* Replace CLASS DEFAULT code by the IF chain. */ default_case->next = if_st; } /* Resolve the internal code. This cannot be done earlier because it requires that the sym->assoc of selectors is set already. */ gfc_current_ns = ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = old_ns; if (ref) free (ref); } /* Resolve a SELECT RANK statement. */ static void resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) { gfc_namespace *ns; gfc_code *body, *new_st, *tail; gfc_case *c; char tname[GFC_MAX_SYMBOL_LEN]; char name[2 * GFC_MAX_SYMBOL_LEN]; gfc_symtree *st; gfc_expr *selector_expr = NULL; int case_value; HOST_WIDE_INT charlen = 0; ns = code->ext.block.ns; gfc_resolve (ns); code->op = EXEC_BLOCK; if (code->expr2) { gfc_association_list* assoc; assoc = gfc_get_association_list (); assoc->st = code->expr1->symtree; assoc->target = gfc_copy_expr (code->expr2); assoc->target->where = code->expr2->where; /* assoc->variable will be set by resolve_assoc_var. */ code->ext.block.assoc = assoc; code->expr1->symtree->n.sym->assoc = assoc; resolve_assoc_var (code->expr1->symtree->n.sym, false); } else code->ext.block.assoc = NULL; /* Loop over RANK cases. Note that returning on the errors causes a cascade of further errors because the case blocks do not compile correctly. */ for (body = code->block; body; body = body->block) { c = body->ext.block.case_list; if (c->low) case_value = (int) mpz_get_si (c->low->value.integer); else case_value = -2; /* Check for repeated cases. */ for (tail = code->block; tail; tail = tail->block) { gfc_case *d = tail->ext.block.case_list; int case_value2; if (tail == body) break; /* Check F2018: C1153. */ if (!c->low && !d->low) gfc_error ("RANK DEFAULT at %L is repeated at %L", &c->where, &d->where); if (!c->low || !d->low) continue; /* Check F2018: C1153. */ case_value2 = (int) mpz_get_si (d->low->value.integer); if ((case_value == case_value2) && case_value == -1) gfc_error ("RANK (*) at %L is repeated at %L", &c->where, &d->where); else if (case_value == case_value2) gfc_error ("RANK (%i) at %L is repeated at %L", case_value, &c->where, &d->where); } if (!c->low) continue; /* Check F2018: C1155. */ if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable || gfc_expr_attr (code->expr1).pointer)) gfc_error ("RANK (*) at %L cannot be used with the pointer or " "allocatable selector at %L", &c->where, &code->expr1->where); if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable || gfc_expr_attr (code->expr1).pointer)) gfc_error ("RANK (*) at %L cannot be used with the pointer or " "allocatable selector at %L", &c->where, &code->expr1->where); } /* Add EXEC_SELECT to switch on rank. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; new_st->expr2 = code->expr2; new_st->block = code->block; code->expr1 = code->expr2 = NULL; code->block = NULL; if (!ns->code) ns->code = new_st; else ns->code->next = new_st; code = new_st; code->op = EXEC_SELECT_RANK; selector_expr = code->expr1; /* Loop over SELECT RANK cases. */ for (body = code->block; body; body = body->block) { c = body->ext.block.case_list; int case_value; /* Pass on the default case. */ if (c->low == NULL) continue; /* Associate temporary to selector. This should only be done when this case is actually true, so build a new ASSOCIATE that does precisely this here (instead of using the 'global' one). */ if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); if (c->ts.type == BT_CLASS) sprintf (tname, "class_%s", c->ts.u.derived->name); else if (c->ts.type == BT_DERIVED) sprintf (tname, "type_%s", c->ts.u.derived->name); else if (c->ts.type != BT_CHARACTER) sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); else sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", gfc_basic_typename (c->ts.type), charlen, c->ts.kind); case_value = (int) mpz_get_si (c->low->value.integer); if (case_value >= 0) sprintf (name, "__tmp_%s_rank_%d", tname, case_value); else sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); st->n.sym->assoc->target->where = selector_expr->where; new_st = gfc_get_code (EXEC_BLOCK); new_st->ext.block.ns = gfc_build_block_ns (ns); new_st->ext.block.ns->code = body->next; body->next = new_st; /* Chain in the new list only if it is marked as dangling. Otherwise there is a CASE label overlap and this is already used. Just ignore, the error is diagnosed elsewhere. */ if (st->n.sym->assoc->dangling) { new_st->ext.block.assoc = st->n.sym->assoc; st->n.sym->assoc->dangling = 0; } resolve_assoc_var (st->n.sym, false); } gfc_current_ns = ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = old_ns; } /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components -- a derived type being transferred doesn't have private components, unless it's being transferred from the module where the type was defined -- we're not trying to transfer a whole assumed size array. */ static void resolve_transfer (gfc_code *code) { gfc_symbol *sym, *derived; gfc_ref *ref; gfc_expr *exp; bool write = false; bool formatted = false; gfc_dt *dt = code->ext.dt; gfc_symbol *dtio_sub = NULL; exp = code->expr1; while (exp != NULL && exp->expr_type == EXPR_OP && exp->value.op.op == INTRINSIC_PARENTHESES) exp = exp->value.op.op1; if (exp && exp->expr_type == EXPR_NULL && code->ext.dt) { gfc_error ("Invalid context for NULL () intrinsic at %L", &exp->where); return; } if (exp == NULL || (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION && exp->expr_type != EXPR_STRUCTURE)) return; /* If we are reading, the variable will be changed. Note that code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE statement -- but in this case, we are not reading, either. */ if (dt && dt->dt_io_kind->value.iokind == M_READ && !gfc_check_vardef_context (exp, false, false, false, _("item in READ"))) return; const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE || exp->expr_type == EXPR_FUNCTION ? &exp->ts : &exp->symtree->n.sym->ts; /* Go to actual component transferred. */ for (ref = exp->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT) ts = &ref->u.c.component->ts; if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE && (ts->type == BT_DERIVED || ts->type == BT_CLASS)) { derived = ts->u.derived; /* Determine when to use the formatted DTIO procedure. */ if (dt && (dt->format_expr || dt->format_label)) formatted = true; write = dt->dt_io_kind->value.iokind == M_WRITE || dt->dt_io_kind->value.iokind == M_PRINT; dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted); if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE) { dt->udtio = exp; sym = exp->symtree->n.sym->ns->proc_name; /* Check to see if this is a nested DTIO call, with the dummy as the io-list object. */ if (sym && sym == dtio_sub && sym->formal && sym->formal->sym == exp->symtree->n.sym && exp->ref == NULL) { if (!sym->attr.recursive) { gfc_error ("DTIO %s procedure at %L must be recursive", sym->name, &sym->declared_at); return; } } } } if (ts->type == BT_CLASS && dtio_sub == NULL) { gfc_error ("Data transfer element at %L cannot be polymorphic unless " "it is processed by a defined input/output procedure", &code->loc); return; } if (ts->type == BT_DERIVED) { /* Check that transferred derived type doesn't contain POINTER components unless it is processed by a defined input/output procedure". */ if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL) { gfc_error ("Data transfer element at %L cannot have POINTER " "components unless it is processed by a defined " "input/output procedure", &code->loc); return; } /* F08:C935. */ if (ts->u.derived->attr.proc_pointer_comp) { gfc_error ("Data transfer element at %L cannot have " "procedure pointer components", &code->loc); return; } if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL) { gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " "components unless it is processed by a defined " "input/output procedure", &code->loc); return; } /* C_PTR and C_FUNPTR have private components which means they cannot be printed. However, if -std=gnu and not -pedantic, allow the component to be printed to help debugging. */ if (ts->u.derived->ts.f90_type == BT_VOID) { if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " "cannot have PRIVATE components", &code->loc)) return; } else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL) { gfc_error ("Data transfer element at %L cannot have " "PRIVATE components unless it is processed by " "a defined input/output procedure", &code->loc); return; } } if (exp->expr_type == EXPR_STRUCTURE) return; sym = exp->symtree->n.sym; if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) { gfc_error ("Data transfer element at %L cannot be a full reference to " "an assumed-size array", &code->loc); return; } if (async_io_dt && exp->expr_type == EXPR_VARIABLE) exp->symtree->n.sym->attr.asynchronous = 1; } /*********** Toplevel code resolution subroutines ***********/ /* Find the set of labels that are reachable from this block. We also record the last statement in each block. */ static void find_reachable_labels (gfc_code *block) { gfc_code *c; if (!block) return; cs_base->reachable_labels = bitmap_alloc (&labels_obstack); /* Collect labels in this block. We don't keep those corresponding to END {IF|SELECT}, these are checked in resolve_branch by going up through the code_stack. */ for (c = block; c; c = c->next) { if (c->here && c->op != EXEC_END_NESTED_BLOCK) bitmap_set_bit (cs_base->reachable_labels, c->here->value); } /* Merge with labels from parent block. */ if (cs_base->prev) { gcc_assert (cs_base->prev->reachable_labels); bitmap_ior_into (cs_base->reachable_labels, cs_base->prev->reachable_labels); } } static void resolve_lock_unlock_event (gfc_code *code) { if (code->expr1->expr_type == EXPR_FUNCTION && code->expr1->value.function.isym && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) remove_caf_get_intrinsic (code->expr1); if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK) && (code->expr1->ts.type != BT_DERIVED || code->expr1->expr_type != EXPR_VARIABLE || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE || code->expr1->rank != 0 || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))) gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", &code->expr1->where); else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT) && (code->expr1->ts.type != BT_DERIVED || code->expr1->expr_type != EXPR_VARIABLE || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE || code->expr1->rank != 0)) gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE", &code->expr1->where); else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)) gfc_error ("Event variable argument at %L must be a coarray or coindexed", &code->expr1->where); else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1)) gfc_error ("Event variable argument at %L must be a coarray but not " "coindexed", &code->expr1->where); /* Check STAT. */ if (code->expr2 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 || code->expr2->expr_type != EXPR_VARIABLE)) gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", &code->expr2->where); if (code->expr2 && !gfc_check_vardef_context (code->expr2, false, false, false, _("STAT variable"))) return; /* Check ERRMSG. */ if (code->expr3 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 || code->expr3->expr_type != EXPR_VARIABLE)) gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", &code->expr3->where); if (code->expr3 && !gfc_check_vardef_context (code->expr3, false, false, false, _("ERRMSG variable"))) return; /* Check for LOCK the ACQUIRED_LOCK. */ if (code->op != EXEC_EVENT_WAIT && code->expr4 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 || code->expr4->expr_type != EXPR_VARIABLE)) gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " "variable", &code->expr4->where); if (code->op != EXEC_EVENT_WAIT && code->expr4 && !gfc_check_vardef_context (code->expr4, false, false, false, _("ACQUIRED_LOCK variable"))) return; /* Check for EVENT WAIT the UNTIL_COUNT. */ if (code->op == EXEC_EVENT_WAIT && code->expr4) { if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0) gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER " "expression", &code->expr4->where); } } static void resolve_critical (gfc_code *code) { gfc_symtree *symtree; gfc_symbol *lock_type; char name[GFC_MAX_SYMBOL_LEN]; static int serial = 0; if (flag_coarray != GFC_FCOARRAY_LIB) return; symtree = gfc_find_symtree (gfc_current_ns->sym_root, GFC_PREFIX ("lock_type")); if (symtree) lock_type = symtree->n.sym; else { if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree, false) != 0) gcc_unreachable (); lock_type = symtree->n.sym; lock_type->attr.flavor = FL_DERIVED; lock_type->attr.zero_comp = 1; lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV; lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE; } sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++); if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0) gcc_unreachable (); code->resolved_sym = symtree->n.sym; symtree->n.sym->attr.flavor = FL_VARIABLE; symtree->n.sym->attr.referenced = 1; symtree->n.sym->attr.artificial = 1; symtree->n.sym->attr.codimension = 1; symtree->n.sym->ts.type = BT_DERIVED; symtree->n.sym->ts.u.derived = lock_type; symtree->n.sym->as = gfc_get_array_spec (); symtree->n.sym->as->corank = 1; symtree->n.sym->as->type = AS_EXPLICIT; symtree->n.sym->as->cotype = AS_EXPLICIT; symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); gfc_commit_symbols(); } static void resolve_sync (gfc_code *code) { /* Check imageset. The * case matches expr1 == NULL. */ if (code->expr1) { if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) gfc_error ("Imageset argument at %L must be a scalar or rank-1 " "INTEGER expression", &code->expr1->where); if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 && mpz_cmp_si (code->expr1->value.integer, 1) < 0) gfc_error ("Imageset argument at %L must between 1 and num_images()", &code->expr1->where); else if (code->expr1->expr_type == EXPR_ARRAY && gfc_simplify_expr (code->expr1, 0)) { gfc_constructor *cons; cons = gfc_constructor_first (code->expr1->value.constructor); for (; cons; cons = gfc_constructor_next (cons)) if (cons->expr->expr_type == EXPR_CONSTANT && mpz_cmp_si (cons->expr->value.integer, 1) < 0) gfc_error ("Imageset argument at %L must between 1 and " "num_images()", &cons->expr->where); } } /* Check STAT. */ gfc_resolve_expr (code->expr2); if (code->expr2 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 || code->expr2->expr_type != EXPR_VARIABLE)) gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", &code->expr2->where); /* Check ERRMSG. */ gfc_resolve_expr (code->expr3); if (code->expr3 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 || code->expr3->expr_type != EXPR_VARIABLE)) gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", &code->expr3->where); } /* Given a branch to a label, see if the branch is conforming. The code node describes where the branch is located. */ static void resolve_branch (gfc_st_label *label, gfc_code *code) { code_stack *stack; if (label == NULL) return; /* Step one: is this a valid branching target? */ if (label->defined == ST_LABEL_UNKNOWN) { gfc_error ("Label %d referenced at %L is never defined", label->value, &code->loc); return; } if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { gfc_error ("Statement at %L is not a valid branch target statement " "for the branch statement at %L", &label->where, &code->loc); return; } /* Step two: make sure this branch is not a branch to itself ;-) */ if (code->here == label) { gfc_warning (0, "Branch at %L may result in an infinite loop", &code->loc); return; } /* Step three: See if the label is in the same block as the branching statement. The hard work has been done by setting up the bitmap reachable_labels. */ if (bitmap_bit_p (cs_base->reachable_labels, label->value)) { /* Check now whether there is a CRITICAL construct; if so, check whether the label is still visible outside of the CRITICAL block, which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) { if (stack->current->op == EXEC_CRITICAL && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves CRITICAL construct for " "label at %L", &code->loc, &label->where); else if (stack->current->op == EXEC_DO_CONCURRENT && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); } return; } /* Step four: If we haven't found the label in the bitmap, it may still be the label of the END of the enclosing block, in which case we find it by going up the code_stack. */ for (stack = cs_base; stack; stack = stack->prev) { if (stack->current->next && stack->current->next->here == label) break; if (stack->current->op == EXEC_CRITICAL) { /* Note: A label at END CRITICAL does not leave the CRITICAL construct as END CRITICAL is still part of it. */ gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" " at %L", &code->loc, &label->where); return; } else if (stack->current->op == EXEC_DO_CONCURRENT) { gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " "label at %L", &code->loc, &label->where); return; } } if (stack) { gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); return; } /* The label is not in an enclosing block, so illegal. This was allowed in Fortran 66, so we allow it as extension. No further checks are necessary in this case. */ gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " "as the GOTO statement at %L", &label->where, &code->loc); return; } /* Check whether EXPR1 has the same shape as EXPR2. */ static bool resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) { mpz_t shape[GFC_MAX_DIMENSIONS]; mpz_t shape2[GFC_MAX_DIMENSIONS]; bool result = false; int i; /* Compare the rank. */ if (expr1->rank != expr2->rank) return result; /* Compare the size of each dimension. */ for (i=0; i<expr1->rank; i++) { if (!gfc_array_dimen_size (expr1, i, &shape[i])) goto ignore; if (!gfc_array_dimen_size (expr2, i, &shape2[i])) goto ignore; if (mpz_cmp (shape[i], shape2[i])) goto over; } /* When either of the two expression is an assumed size array, we ignore the comparison of dimension sizes. */ ignore: result = true; over: gfc_clear_shape (shape, i); gfc_clear_shape (shape2, i); return result; } /* Check whether a WHERE assignment target or a WHERE mask expression has the same shape as the outmost WHERE mask expression. */ static void resolve_where (gfc_code *code, gfc_expr *mask) { gfc_code *cblock; gfc_code *cnext; gfc_expr *e = NULL; cblock = code->block; /* Store the first WHERE mask-expr of the WHERE statement or construct. In case of nested WHERE, only the outmost one is stored. */ if (mask == NULL) /* outmost WHERE */ e = cblock->expr1; else /* inner WHERE */ e = mask; while (cblock) { if (cblock->expr1) { /* Check if the mask-expr has a consistent shape with the outmost WHERE mask-expr. */ if (!resolve_where_shape (cblock->expr1, e)) gfc_error ("WHERE mask at %L has inconsistent shape", &cblock->expr1->where); } /* the assignment statement of a WHERE statement, or the first statement in where-body-construct of a WHERE construct */ cnext = cblock->next; while (cnext) { switch (cnext->op) { /* WHERE assignment statement */ case EXEC_ASSIGN: /* Check shape consistent for WHERE assignment target. */ if (e && !resolve_where_shape (cnext->expr1, e)) gfc_error ("WHERE assignment target at %L has " "inconsistent shape", &cnext->expr1->where); break; case EXEC_ASSIGN_CALL: resolve_call (cnext); if (!cnext->resolved_sym->attr.elemental) gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", &cnext->ext.actual->expr->where); break; /* WHERE or WHERE construct is part of a where-body-construct */ case EXEC_WHERE: resolve_where (cnext, e); break; default: gfc_error ("Unsupported statement inside WHERE at %L", &cnext->loc); } /* the next statement within the same where-body-construct */ cnext = cnext->next; } /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ cblock = cblock->block; } } /* Resolve assignment in FORALL construct. NVAR is the number of FORALL index variables, and VAR_EXPR records the FORALL index variables. */ static void gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) { int n; for (n = 0; n < nvar; n++) { gfc_symbol *forall_index; forall_index = var_expr[n]->symtree->n.sym; /* Check whether the assignment target is one of the FORALL index variable. */ if ((code->expr1->expr_type == EXPR_VARIABLE) && (code->expr1->symtree->n.sym == forall_index)) gfc_error ("Assignment to a FORALL index variable at %L", &code->expr1->where); else { /* If one of the FORALL index variables doesn't appear in the assignment variable, then there could be a many-to-one assignment. Emit a warning rather than an error because the mask could be resolving this problem. */ if (!find_forall_index (code->expr1, forall_index, 0)) gfc_warning (0, "The FORALL with index %qs is not used on the " "left side of the assignment at %L and so might " "cause multiple assignment to this object", var_expr[n]->symtree->name, &code->expr1->where); } } } /* Resolve WHERE statement in FORALL construct. */ static void gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) { gfc_code *cblock; gfc_code *cnext; cblock = code->block; while (cblock) { /* the assignment statement of a WHERE statement, or the first statement in where-body-construct of a WHERE construct */ cnext = cblock->next; while (cnext) { switch (cnext->op) { /* WHERE assignment statement */ case EXEC_ASSIGN: gfc_resolve_assign_in_forall (cnext, nvar, var_expr); break; /* WHERE operator assignment statement */ case EXEC_ASSIGN_CALL: resolve_call (cnext); if (!cnext->resolved_sym->attr.elemental) gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", &cnext->ext.actual->expr->where); break; /* WHERE or WHERE construct is part of a where-body-construct */ case EXEC_WHERE: gfc_resolve_where_code_in_forall (cnext, nvar, var_expr); break; default: gfc_error ("Unsupported statement inside WHERE at %L", &cnext->loc); } /* the next statement within the same where-body-construct */ cnext = cnext->next; } /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ cblock = cblock->block; } } /* Traverse the FORALL body to check whether the following errors exist: 1. For assignment, check if a many-to-one assignment happens. 2. For WHERE statement, check the WHERE body to see if there is any many-to-one assignment. */ static void gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) { gfc_code *c; c = code->block->next; while (c) { switch (c->op) { case EXEC_ASSIGN: case EXEC_POINTER_ASSIGN: gfc_resolve_assign_in_forall (c, nvar, var_expr); break; case EXEC_ASSIGN_CALL: resolve_call (c); break; /* Because the gfc_resolve_blocks() will handle the nested FORALL, there is no need to handle it here. */ case EXEC_FORALL: break; case EXEC_WHERE: gfc_resolve_where_code_in_forall(c, nvar, var_expr); break; default: break; } /* The next statement in the FORALL body. */ c = c->next; } } /* Counts the number of iterators needed inside a forall construct, including nested forall constructs. This is used to allocate the needed memory in gfc_resolve_forall. */ static int gfc_count_forall_iterators (gfc_code *code) { int max_iters, sub_iters, current_iters; gfc_forall_iterator *fa; gcc_assert(code->op == EXEC_FORALL); max_iters = 0; current_iters = 0; for (fa = code->ext.forall_iterator; fa; fa = fa->next) current_iters ++; code = code->block->next; while (code) { if (code->op == EXEC_FORALL) { sub_iters = gfc_count_forall_iterators (code); if (sub_iters > max_iters) max_iters = sub_iters; } code = code->next; } return current_iters + max_iters; } /* Given a FORALL construct, first resolve the FORALL iterator, then call gfc_resolve_forall_body to resolve the FORALL body. */ static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) { static gfc_expr **var_expr; static int total_var = 0; static int nvar = 0; int i, old_nvar, tmp; gfc_forall_iterator *fa; old_nvar = nvar; if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) return; /* Start to resolve a FORALL construct */ if (forall_save == 0) { /* Count the total number of FORALL indices in the nested FORALL construct in order to allocate the VAR_EXPR with proper size. */ total_var = gfc_count_forall_iterators (code); /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ var_expr = XCNEWVEC (gfc_expr *, total_var); } /* The information about FORALL iterator, including FORALL indices start, end and stride. An outer FORALL indice cannot appear in start, end or stride. */ for (fa = code->ext.forall_iterator; fa; fa = fa->next) { /* Fortran 20008: C738 (R753). */ if (fa->var->ref && fa->var->ref->type == REF_ARRAY) { gfc_error ("FORALL index-name at %L must be a scalar variable " "of type integer", &fa->var->where); continue; } /* Check if any outer FORALL index name is the same as the current one. */ for (i = 0; i < nvar; i++) { if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) gfc_error ("An outer FORALL construct already has an index " "with this name %L", &fa->var->where); } /* Record the current FORALL index. */ var_expr[nvar] = gfc_copy_expr (fa->var); nvar++; /* No memory leak. */ gcc_assert (nvar <= total_var); } /* Resolve the FORALL body. */ gfc_resolve_forall_body (code, nvar, var_expr); /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ gfc_resolve_blocks (code->block, ns); tmp = nvar; nvar = old_nvar; /* Free only the VAR_EXPRs allocated in this frame. */ for (i = nvar; i < tmp; i++) gfc_free_expr (var_expr[i]); if (nvar == 0) { /* We are in the outermost FORALL construct. */ gcc_assert (forall_save == 0); /* VAR_EXPR is not needed any more. */ free (var_expr); total_var = 0; } } /* Resolve a BLOCK construct statement. */ static void resolve_block_construct (gfc_code* code) { /* Resolve the BLOCK's namespace. */ gfc_resolve (code->ext.block.ns); /* For an ASSOCIATE block, the associations (and their targets) are already resolved during resolve_symbol. */ } /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and DO code nodes. */ void gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) { bool t; for (; b; b = b->block) { t = gfc_resolve_expr (b->expr1); if (!gfc_resolve_expr (b->expr2)) t = false; switch (b->op) { case EXEC_IF: if (t && b->expr1 != NULL && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) gfc_error ("IF clause at %L requires a scalar LOGICAL expression", &b->expr1->where); break; case EXEC_WHERE: if (t && b->expr1 != NULL && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", &b->expr1->where); break; case EXEC_GOTO: resolve_branch (b->label1, b); break; case EXEC_BLOCK: resolve_block_construct (b); break; case EXEC_SELECT: case EXEC_SELECT_TYPE: case EXEC_SELECT_RANK: case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: case EXEC_DO_CONCURRENT: case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: case EXEC_IOLENGTH: case EXEC_WAIT: break; case EXEC_OMP_ATOMIC: case EXEC_OACC_ATOMIC: { gfc_omp_atomic_op aop = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK); /* Verify this before calling gfc_resolve_code, which might change it. */ gcc_assert (b->next && b->next->op == EXEC_ASSIGN); gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && b->next->next == NULL) || ((aop == GFC_OMP_ATOMIC_CAPTURE) && b->next->next != NULL && b->next->next->op == EXEC_ASSIGN && b->next->next->next == NULL)); } break; case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS_LOOP: case EXEC_OACC_KERNELS: case EXEC_OACC_SERIAL_LOOP: case EXEC_OACC_SERIAL: case EXEC_OACC_DATA: case EXEC_OACC_HOST_DATA: case EXEC_OACC_LOOP: case EXEC_OACC_UPDATE: case EXEC_OACC_WAIT: case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ROUTINE: case EXEC_OMP_CRITICAL: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_MASTER: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: case EXEC_OMP_TARGET: case EXEC_OMP_TARGET_DATA: case EXEC_OMP_TARGET_ENTER_DATA: case EXEC_OMP_TARGET_EXIT_DATA: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: case EXEC_OMP_TASKLOOP: case EXEC_OMP_TASKLOOP_SIMD: case EXEC_OMP_TASKWAIT: case EXEC_OMP_TASKYIELD: case EXEC_OMP_TEAMS: case EXEC_OMP_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_WORKSHARE: break; default: gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); } gfc_resolve_code (b->next, ns); } } /* Does everything to resolve an ordinary assignment. Returns true if this is an interface assignment. */ static bool resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) { bool rval = false; gfc_expr *lhs; gfc_expr *rhs; int n; gfc_ref *ref; symbol_attribute attr; if (gfc_extend_assign (code, ns)) { gfc_expr** rhsptr; if (code->op == EXEC_ASSIGN_CALL) { lhs = code->ext.actual->expr; rhsptr = &code->ext.actual->next->expr; } else { gfc_actual_arglist* args; gfc_typebound_proc* tbp; gcc_assert (code->op == EXEC_COMPCALL); args = code->expr1->value.compcall.actual; lhs = args->expr; rhsptr = &args->next->expr; tbp = code->expr1->value.compcall.tbp; gcc_assert (!tbp->is_generic); } /* Make a temporary rhs when there is a default initializer and rhs is the same symbol as the lhs. */ if ((*rhsptr)->expr_type == EXPR_VARIABLE && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) *rhsptr = gfc_get_parentheses (*rhsptr); return true; } lhs = code->expr1; rhs = code->expr2; if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) && rhs->ts.type == BT_CHARACTER && rhs->expr_type != EXPR_CONSTANT) { /* Use of -fdec-char-conversions allows assignment of character data to non-character variables. This not permited for nonconstant strings. */ gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs), gfc_typename (lhs), &rhs->where); return false; } /* Handle the case of a BOZ literal on the RHS. */ if (rhs->ts.type == BT_BOZ) { if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA " "statement value nor an actual argument of " "INT/REAL/DBLE/CMPLX intrinsic subprogram", &rhs->where)) return false; switch (lhs->ts.type) { case BT_INTEGER: if (!gfc_boz2int (rhs, lhs->ts.kind)) return false; break; case BT_REAL: if (!gfc_boz2real (rhs, lhs->ts.kind)) return false; break; default: gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where); return false; } } if (lhs->ts.type == BT_CHARACTER && warn_character_truncation) { HOST_WIDE_INT llen = 0, rlen = 0; if (lhs->ts.u.cl != NULL && lhs->ts.u.cl->length != NULL && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer); if (rhs->expr_type == EXPR_CONSTANT) rlen = rhs->value.character.length; else if (rhs->ts.u.cl != NULL && rhs->ts.u.cl->length != NULL && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer); if (rlen && llen && rlen > llen) gfc_warning_now (OPT_Wcharacter_truncation, "CHARACTER expression will be truncated " "in assignment (%ld/%ld) at %L", (long) llen, (long) rlen, &code->loc); } /* Ensure that a vector index expression for the lvalue is evaluated to a temporary if the lvalue symbol is referenced in it. */ if (lhs->rank) { for (ref = lhs->ref; ref; ref= ref->next) if (ref->type == REF_ARRAY) { for (n = 0; n < ref->u.ar.dimen; n++) if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR && gfc_find_sym_in_expr (lhs->symtree->n.sym, ref->u.ar.start[n])) ref->u.ar.start[n] = gfc_get_parentheses (ref->u.ar.start[n]); } } if (gfc_pure (NULL)) { if (lhs->ts.type == BT_DERIVED && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp && rhs->expr_type == EXPR_VARIABLE && (gfc_impure_variable (rhs->symtree->n.sym) || gfc_is_coindexed (rhs))) { /* F2008, C1283. */ if (gfc_is_coindexed (rhs)) gfc_error ("Coindexed expression at %L is assigned to " "a derived type variable with a POINTER " "component in a PURE procedure", &rhs->where); else /* F2008, C1283 (4). */ gfc_error ("In a pure subprogram an INTENT(IN) dummy argument " "shall not be used as the expr at %L of an intrinsic " "assignment statement in which the variable is of a " "derived type if the derived type has a pointer " "component at any level of component selection.", &rhs->where); return rval; } /* Fortran 2008, C1283. */ if (gfc_is_coindexed (lhs)) { gfc_error ("Assignment to coindexed variable at %L in a PURE " "procedure", &rhs->where); return rval; } } if (gfc_implicit_pure (NULL)) { if (lhs->expr_type == EXPR_VARIABLE && lhs->symtree->n.sym != gfc_current_ns->proc_name && lhs->symtree->n.sym->ns != gfc_current_ns) gfc_unset_implicit_pure (NULL); if (lhs->ts.type == BT_DERIVED && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp && rhs->expr_type == EXPR_VARIABLE && (gfc_impure_variable (rhs->symtree->n.sym) || gfc_is_coindexed (rhs))) gfc_unset_implicit_pure (NULL); /* Fortran 2008, C1283. */ if (gfc_is_coindexed (lhs)) gfc_unset_implicit_pure (NULL); } /* F2008, 7.2.1.2. */ attr = gfc_expr_attr (lhs); if (lhs->ts.type == BT_CLASS && attr.allocatable) { if (attr.codimension) { gfc_error ("Assignment to polymorphic coarray at %L is not " "permitted", &lhs->where); return false; } if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable " "polymorphic variable at %L", &lhs->where)) return false; if (!flag_realloc_lhs) { gfc_error ("Assignment to an allocatable polymorphic variable at %L " "requires %<-frealloc-lhs%>", &lhs->where); return false; } } else if (lhs->ts.type == BT_CLASS) { gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic " "assignment at %L - check that there is a matching specific " "subroutine for '=' operator", &lhs->where); return false; } bool lhs_coindexed = gfc_is_coindexed (lhs); /* F2008, Section 7.2.1.2. */ if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) { gfc_error ("Coindexed variable must not have an allocatable ultimate " "component in assignment at %L", &lhs->where); return false; } /* Assign the 'data' of a class object to a derived type. */ if (lhs->ts.type == BT_DERIVED && rhs->ts.type == BT_CLASS && rhs->expr_type != EXPR_ARRAY) gfc_add_data_component (rhs); /* Make sure there is a vtable and, in particular, a _copy for the rhs type. */ if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS) gfc_find_vtab (&rhs->ts); bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB && (lhs_coindexed || (code->expr2->expr_type == EXPR_FUNCTION && code->expr2->value.function.isym && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET && (code->expr1->rank == 0 || code->expr2->rank != 0) && !gfc_expr_attr (rhs).allocatable && !gfc_has_vector_subscript (rhs))); gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send); /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable. Additionally, insert this code when the RHS is a CAF as we then use the GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if the LHS is (re)allocatable or has a vector subscript. If the LHS is a noncoindexed array and the RHS is a coindexed scalar, use the normal code path. */ if (caf_convert_to_send) { if (code->expr2->expr_type == EXPR_FUNCTION && code->expr2->value.function.isym && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET) remove_caf_get_intrinsic (code->expr2); code->op = EXEC_CALL; gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); code->resolved_sym = code->symtree->n.sym; code->resolved_sym->attr.flavor = FL_PROCEDURE; code->resolved_sym->attr.intrinsic = 1; code->resolved_sym->attr.subroutine = 1; code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); gfc_commit_symbol (code->resolved_sym); code->ext.actual = gfc_get_actual_arglist (); code->ext.actual->expr = lhs; code->ext.actual->next = gfc_get_actual_arglist (); code->ext.actual->next->expr = rhs; code->expr1 = NULL; code->expr2 = NULL; } return false; } /* Add a component reference onto an expression. */ static void add_comp_ref (gfc_expr *e, gfc_component *c) { gfc_ref **ref; ref = &(e->ref); while (*ref) ref = &((*ref)->next); *ref = gfc_get_ref (); (*ref)->type = REF_COMPONENT; (*ref)->u.c.sym = e->ts.u.derived; (*ref)->u.c.component = c; e->ts = c->ts; /* Add a full array ref, as necessary. */ if (c->as) { gfc_add_full_array_ref (e, c->as); e->rank = c->as->rank; } } /* Build an assignment. Keep the argument 'op' for future use, so that pointer assignments can be made. */ static gfc_code * build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, gfc_component *comp1, gfc_component *comp2, locus loc) { gfc_code *this_code; this_code = gfc_get_code (op); this_code->next = NULL; this_code->expr1 = gfc_copy_expr (expr1); this_code->expr2 = gfc_copy_expr (expr2); this_code->loc = loc; if (comp1 && comp2) { add_comp_ref (this_code->expr1, comp1); add_comp_ref (this_code->expr2, comp2); } return this_code; } /* Makes a temporary variable expression based on the characteristics of a given variable expression. */ static gfc_expr* get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) { static int serial = 0; char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; gfc_array_spec *as; gfc_array_ref *aref; gfc_ref *ref; sprintf (name, GFC_PREFIX("DA%d"), serial++); gfc_get_sym_tree (name, ns, &tmp, false); gfc_add_type (tmp->n.sym, &e->ts, NULL); if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER) tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, e->value.character.length); as = NULL; ref = NULL; aref = NULL; /* Obtain the arrayspec for the temporary. */ if (e->rank && e->expr_type != EXPR_ARRAY && e->expr_type != EXPR_FUNCTION && e->expr_type != EXPR_OP) { aref = gfc_find_array_ref (e); if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->as == aref->as) as = aref->as; else { for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_COMPONENT && ref->u.c.component->as == aref->as) { as = aref->as; break; } } } /* Add the attributes and the arrayspec to the temporary. */ tmp->n.sym->attr = gfc_expr_attr (e); tmp->n.sym->attr.function = 0; tmp->n.sym->attr.result = 0; tmp->n.sym->attr.flavor = FL_VARIABLE; tmp->n.sym->attr.dummy = 0; tmp->n.sym->attr.intent = INTENT_UNKNOWN; if (as) { tmp->n.sym->as = gfc_copy_array_spec (as); if (!ref) ref = e->ref; if (as->type == AS_DEFERRED) tmp->n.sym->attr.allocatable = 1; } else if (e->rank && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION || e->expr_type == EXPR_OP)) { tmp->n.sym->as = gfc_get_array_spec (); tmp->n.sym->as->type = AS_DEFERRED; tmp->n.sym->as->rank = e->rank; tmp->n.sym->attr.allocatable = 1; tmp->n.sym->attr.dimension = 1; } else tmp->n.sym->attr.dimension = 0; gfc_set_sym_referenced (tmp->n.sym); gfc_commit_symbol (tmp->n.sym); e = gfc_lval_expr_from_sym (tmp->n.sym); /* Should the lhs be a section, use its array ref for the temporary expression. */ if (aref && aref->type != AR_FULL) { gfc_free_ref_list (e->ref); e->ref = gfc_copy_ref (ref); } return e; } /* Add one line of code to the code chain, making sure that 'head' and 'tail' are appropriately updated. */ static void add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) { gcc_assert (this_code); if (*head == NULL) *head = *tail = *this_code; else *tail = gfc_append_code (*tail, *this_code); *this_code = NULL; } /* Counts the potential number of part array references that would result from resolution of typebound defined assignments. */ static int nonscalar_typebound_assign (gfc_symbol *derived, int depth) { gfc_component *c; int c_depth = 0, t_depth; for (c= derived->components; c; c = c->next) { if ((!gfc_bt_struct (c->ts.type) || c->attr.pointer || c->attr.allocatable || c->attr.proc_pointer_comp || c->attr.class_pointer || c->attr.proc_pointer) && !c->attr.defined_assign_comp) continue; if (c->as && c_depth == 0) c_depth = 1; if (c->ts.u.derived->attr.defined_assign_comp) t_depth = nonscalar_typebound_assign (c->ts.u.derived, c->as ? 1 : 0); else t_depth = 0; c_depth = t_depth > c_depth ? t_depth : c_depth; } return depth + c_depth; } /* Implement 7.2.1.3 of the F08 standard: "An intrinsic assignment where the variable is of derived type is performed as if each component of the variable were assigned from the corresponding component of expr using pointer assignment (7.2.2) for each pointer component, defined assignment for each nonpointer nonallocatable component of a type that has a type-bound defined assignment consistent with the component, intrinsic assignment for each other nonpointer nonallocatable component, ..." The pointer assignments are taken care of by the intrinsic assignment of the structure itself. This function recursively adds defined assignments where required. The recursion is accomplished by calling gfc_resolve_code. When the lhs in a defined assignment has intent INOUT, we need a temporary for the lhs. In pseudo-code: ! Only call function lhs once. if (lhs is not a constant or an variable) temp_x = expr2 expr2 => temp_x ! Do the intrinsic assignment expr1 = expr2 ! Now do the defined assignments do over components with typebound defined assignment [%cmp] #if one component's assignment procedure is INOUT t1 = expr1 #if expr2 non-variable temp_x = expr2 expr2 => temp_x # endif expr1 = expr2 # for each cmp t1%cmp {defined=} expr2%cmp expr1%cmp = t1%cmp #else expr1 = expr2 # for each cmp expr1%cmp {defined=} expr2%cmp #endif */ /* The temporary assignments have to be put on top of the additional code to avoid the result being changed by the intrinsic assignment. */ static int component_assignment_level = 0; static gfc_code *tmp_head = NULL, *tmp_tail = NULL; static void generate_component_assignments (gfc_code **code, gfc_namespace *ns) { gfc_component *comp1, *comp2; gfc_code *this_code = NULL, *head = NULL, *tail = NULL; gfc_expr *t1; int error_count, depth; gfc_get_errors (NULL, &error_count); /* Filter out continuing processing after an error. */ if (error_count || (*code)->expr1->ts.type != BT_DERIVED || (*code)->expr2->ts.type != BT_DERIVED) return; /* TODO: Handle more than one part array reference in assignments. */ depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived, (*code)->expr1->rank ? 1 : 0); if (depth > 1) { gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not " "done because multiple part array references would " "occur in intermediate expressions.", &(*code)->loc); return; } component_assignment_level++; /* Create a temporary so that functions get called only once. */ if ((*code)->expr2->expr_type != EXPR_VARIABLE && (*code)->expr2->expr_type != EXPR_CONSTANT) { gfc_expr *tmp_expr; /* Assign the rhs to the temporary. */ tmp_expr = get_temp_from_expr ((*code)->expr1, ns); this_code = build_assignment (EXEC_ASSIGN, tmp_expr, (*code)->expr2, NULL, NULL, (*code)->loc); /* Add the code and substitute the rhs expression. */ add_code_to_chain (&this_code, &tmp_head, &tmp_tail); gfc_free_expr ((*code)->expr2); (*code)->expr2 = tmp_expr; } /* Do the intrinsic assignment. This is not needed if the lhs is one of the temporaries generated here, since the intrinsic assignment to the final result already does this. */ if ((*code)->expr1->symtree->n.sym->name[2] != '@') { this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, (*code)->expr2, NULL, NULL, (*code)->loc); add_code_to_chain (&this_code, &head, &tail); } comp1 = (*code)->expr1->ts.u.derived->components; comp2 = (*code)->expr2->ts.u.derived->components; t1 = NULL; for (; comp1; comp1 = comp1->next, comp2 = comp2->next) { bool inout = false; /* The intrinsic assignment does the right thing for pointers of all kinds and allocatable components. */ if (!gfc_bt_struct (comp1->ts.type) || comp1->attr.pointer || comp1->attr.allocatable || comp1->attr.proc_pointer_comp || comp1->attr.class_pointer || comp1->attr.proc_pointer) continue; /* Make an assigment for this component. */ this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, (*code)->expr2, comp1, comp2, (*code)->loc); /* Convert the assignment if there is a defined assignment for this type. Otherwise, using the call from gfc_resolve_code, recurse into its components. */ gfc_resolve_code (this_code, ns); if (this_code->op == EXEC_ASSIGN_CALL) { gfc_formal_arglist *dummy_args; gfc_symbol *rsym; /* Check that there is a typebound defined assignment. If not, then this must be a module defined assignment. We cannot use the defined_assign_comp attribute here because it must be this derived type that has the defined assignment and not a parent type. */ if (!(comp1->ts.u.derived->f2k_derived && comp1->ts.u.derived->f2k_derived ->tb_op[INTRINSIC_ASSIGN])) { gfc_free_statements (this_code); this_code = NULL; continue; } /* If the first argument of the subroutine has intent INOUT a temporary must be generated and used instead. */ rsym = this_code->resolved_sym; dummy_args = gfc_sym_get_dummy_args (rsym); if (dummy_args && dummy_args->sym->attr.intent == INTENT_INOUT) { gfc_code *temp_code; inout = true; /* Build the temporary required for the assignment and put it at the head of the generated code. */ if (!t1) { t1 = get_temp_from_expr ((*code)->expr1, ns); temp_code = build_assignment (EXEC_ASSIGN, t1, (*code)->expr1, NULL, NULL, (*code)->loc); /* For allocatable LHS, check whether it is allocated. Note that allocatable components with defined assignment are not yet support. See PR 57696. */ if ((*code)->expr1->symtree->n.sym->attr.allocatable) { gfc_code *block; gfc_expr *e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); block = gfc_get_code (EXEC_IF); block->block = gfc_get_code (EXEC_IF); block->block->expr1 = gfc_build_intrinsic_call (ns, GFC_ISYM_ALLOCATED, "allocated", (*code)->loc, 1, e); block->block->next = temp_code; temp_code = block; } add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); } /* Replace the first actual arg with the component of the temporary. */ gfc_free_expr (this_code->ext.actual->expr); this_code->ext.actual->expr = gfc_copy_expr (t1); add_comp_ref (this_code->ext.actual->expr, comp1); /* If the LHS variable is allocatable and wasn't allocated and the temporary is allocatable, pointer assign the address of the freshly allocated LHS to the temporary. */ if ((*code)->expr1->symtree->n.sym->attr.allocatable && gfc_expr_attr ((*code)->expr1).allocatable) { gfc_code *block; gfc_expr *cond; cond = gfc_get_expr (); cond->ts.type = BT_LOGICAL; cond->ts.kind = gfc_default_logical_kind; cond->expr_type = EXPR_OP; cond->where = (*code)->loc; cond->value.op.op = INTRINSIC_NOT; cond->value.op.op1 = gfc_build_intrinsic_call (ns, GFC_ISYM_ALLOCATED, "allocated", (*code)->loc, 1, gfc_copy_expr (t1)); block = gfc_get_code (EXEC_IF); block->block = gfc_get_code (EXEC_IF); block->block->expr1 = cond; block->block->next = build_assignment (EXEC_POINTER_ASSIGN, t1, (*code)->expr1, NULL, NULL, (*code)->loc); add_code_to_chain (&block, &head, &tail); } } } else if (this_code->op == EXEC_ASSIGN && !this_code->next) { /* Don't add intrinsic assignments since they are already effected by the intrinsic assignment of the structure. */ gfc_free_statements (this_code); this_code = NULL; continue; } add_code_to_chain (&this_code, &head, &tail); if (t1 && inout) { /* Transfer the value to the final result. */ this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, t1, comp1, comp2, (*code)->loc); add_code_to_chain (&this_code, &head, &tail); } } /* Put the temporary assignments at the top of the generated code. */ if (tmp_head && component_assignment_level == 1) { gfc_append_code (tmp_head, head); head = tmp_head; tmp_head = tmp_tail = NULL; } // If we did a pointer assignment - thus, we need to ensure that the LHS is // not accidentally deallocated. Hence, nullify t1. if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable && gfc_expr_attr ((*code)->expr1).allocatable) { gfc_code *block; gfc_expr *cond; gfc_expr *e; e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", (*code)->loc, 2, gfc_copy_expr (t1), e); block = gfc_get_code (EXEC_IF); block->block = gfc_get_code (EXEC_IF); block->block->expr1 = cond; block->block->next = build_assignment (EXEC_POINTER_ASSIGN, t1, gfc_get_null_expr (&(*code)->loc), NULL, NULL, (*code)->loc); gfc_append_code (tail, block); tail = block; } /* Now attach the remaining code chain to the input code. Step on to the end of the new code since resolution is complete. */ gcc_assert ((*code)->op == EXEC_ASSIGN); tail->next = (*code)->next; /* Overwrite 'code' because this would place the intrinsic assignment before the temporary for the lhs is created. */ gfc_free_expr ((*code)->expr1); gfc_free_expr ((*code)->expr2); **code = *head; if (head != tail) free (head); *code = tail; component_assignment_level--; } /* F2008: Pointer function assignments are of the form: ptr_fcn (args) = expr This function breaks these assignments into two statements: temporary_pointer => ptr_fcn(args) temporary_pointer = expr */ static bool resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) { gfc_expr *tmp_ptr_expr; gfc_code *this_code; gfc_component *comp; gfc_symbol *s; if ((*code)->expr1->expr_type != EXPR_FUNCTION) return false; /* Even if standard does not support this feature, continue to build the two statements to avoid upsetting frontend_passes.c. */ gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at " "%L", &(*code)->loc); comp = gfc_get_proc_ptr_comp ((*code)->expr1); if (comp) s = comp->ts.interface; else s = (*code)->expr1->symtree->n.sym; if (s == NULL || !s->result->attr.pointer) { gfc_error ("The function result on the lhs of the assignment at " "%L must have the pointer attribute.", &(*code)->expr1->where); (*code)->op = EXEC_NOP; return false; } tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns); /* get_temp_from_expression is set up for ordinary assignments. To that end, where array bounds are not known, arrays are made allocatable. Change the temporary to a pointer here. */ tmp_ptr_expr->symtree->n.sym->attr.pointer = 1; tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0; tmp_ptr_expr->where = (*code)->loc; this_code = build_assignment (EXEC_ASSIGN, tmp_ptr_expr, (*code)->expr2, NULL, NULL, (*code)->loc); this_code->next = (*code)->next; (*code)->next = this_code; (*code)->op = EXEC_POINTER_ASSIGN; (*code)->expr2 = (*code)->expr1; (*code)->expr1 = tmp_ptr_expr; return true; } /* Deferred character length assignments from an operator expression require a temporary because the character length of the lhs can change in the course of the assignment. */ static bool deferred_op_assign (gfc_code **code, gfc_namespace *ns) { gfc_expr *tmp_expr; gfc_code *this_code; if (!((*code)->expr1->ts.type == BT_CHARACTER && (*code)->expr1->ts.deferred && (*code)->expr1->rank && (*code)->expr2->expr_type == EXPR_OP)) return false; if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1)) return false; if (gfc_expr_attr ((*code)->expr1).pointer) return false; tmp_expr = get_temp_from_expr ((*code)->expr1, ns); tmp_expr->where = (*code)->loc; /* A new charlen is required to ensure that the variable string length is different to that of the original lhs. */ tmp_expr->ts.u.cl = gfc_get_charlen(); tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl; tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next; (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl; tmp_expr->symtree->n.sym->ts.deferred = 1; this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, gfc_copy_expr (tmp_expr), NULL, NULL, (*code)->loc); (*code)->expr1 = tmp_expr; this_code->next = (*code)->next; (*code)->next = this_code; return true; } /* Given a block of code, recursively resolve everything pointed to by this code block. */ void gfc_resolve_code (gfc_code *code, gfc_namespace *ns) { int omp_workshare_save; int forall_save, do_concurrent_save; code_stack frame; bool t; frame.prev = cs_base; frame.head = code; cs_base = &frame; find_reachable_labels (code); for (; code; code = code->next) { frame.current = code; forall_save = forall_flag; do_concurrent_save = gfc_do_concurrent_flag; if (code->op == EXEC_FORALL) { forall_flag = 1; gfc_resolve_forall (code, ns, forall_save); forall_flag = 2; } else if (code->block) { omp_workshare_save = -1; switch (code->op) { case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS_LOOP: case EXEC_OACC_KERNELS: case EXEC_OACC_SERIAL_LOOP: case EXEC_OACC_SERIAL: case EXEC_OACC_DATA: case EXEC_OACC_HOST_DATA: case EXEC_OACC_LOOP: gfc_resolve_oacc_blocks (code, ns); break; case EXEC_OMP_PARALLEL_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; gfc_resolve_omp_parallel_blocks (code, ns); break; case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TASK: case EXEC_OMP_TASKLOOP: case EXEC_OMP_TASKLOOP_SIMD: case EXEC_OMP_TEAMS: case EXEC_OMP_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 0; gfc_resolve_omp_parallel_blocks (code, ns); break; case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_SIMD: case EXEC_OMP_TARGET_SIMD: gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: /* Blocks are handled in resolve_select_type because we have to transform the SELECT TYPE into ASSOCIATE first. */ break; case EXEC_DO_CONCURRENT: gfc_do_concurrent_flag = 1; gfc_resolve_blocks (code->block, ns); gfc_do_concurrent_flag = 2; break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; /* FALL THROUGH */ default: gfc_resolve_blocks (code->block, ns); break; } if (omp_workshare_save != -1) omp_workshare_flag = omp_workshare_save; } start: t = true; if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; gfc_do_concurrent_flag = do_concurrent_save; if (!gfc_resolve_expr (code->expr2)) t = false; if (code->op == EXEC_ALLOCATE && !gfc_resolve_expr (code->expr3)) t = false; switch (code->op) { case EXEC_NOP: case EXEC_END_BLOCK: case EXEC_END_NESTED_BLOCK: case EXEC_CYCLE: case EXEC_PAUSE: case EXEC_STOP: case EXEC_ERROR_STOP: case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: case EXEC_ASSIGN_CALL: break; case EXEC_CRITICAL: resolve_critical (code); break; case EXEC_SYNC_ALL: case EXEC_SYNC_IMAGES: case EXEC_SYNC_MEMORY: resolve_sync (code); break; case EXEC_LOCK: case EXEC_UNLOCK: case EXEC_EVENT_POST: case EXEC_EVENT_WAIT: resolve_lock_unlock_event (code); break; case EXEC_FAIL_IMAGE: case EXEC_FORM_TEAM: case EXEC_CHANGE_TEAM: case EXEC_END_TEAM: case EXEC_SYNC_TEAM: break; case EXEC_ENTRY: /* Keep track of which entry we are up to. */ current_entry_id = code->ext.entry->id; break; case EXEC_WHERE: resolve_where (code, NULL); break; case EXEC_GOTO: if (code->expr1 != NULL) { if (code->expr1->ts.type != BT_INTEGER) gfc_error ("ASSIGNED GOTO statement at %L requires an " "INTEGER variable", &code->expr1->where); else if (code->expr1->symtree->n.sym->attr.assign != 1) gfc_error ("Variable %qs has not been assigned a target " "label at %L", code->expr1->symtree->n.sym->name, &code->expr1->where); } else resolve_branch (code->label1, code); break; case EXEC_RETURN: if (code->expr1 != NULL && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" "INTEGER return specifier", &code->expr1->where); break; case EXEC_INIT_ASSIGN: case EXEC_END_PROCEDURE: break; case EXEC_ASSIGN: if (!t) break; /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on the LHS. */ if (code->expr1->expr_type == EXPR_FUNCTION && code->expr1->value.function.isym && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) remove_caf_get_intrinsic (code->expr1); /* If this is a pointer function in an lvalue variable context, the new code will have to be resolved afresh. This is also the case with an error, where the code is transformed into NOP to prevent ICEs downstream. */ if (resolve_ptr_fcn_assign (&code, ns) || code->op == EXEC_NOP) goto start; if (!gfc_check_vardef_context (code->expr1, false, false, false, _("assignment"))) break; if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) goto compcall; else goto call; } /* Check for dependencies in deferred character length array assignments and generate a temporary, if necessary. */ if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns)) break; /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED && code->expr1->ts.u.derived && code->expr1->ts.u.derived->attr.defined_assign_comp) generate_component_assignments (&code, ns); break; case EXEC_LABEL_ASSIGN: if (code->label1->defined == ST_LABEL_UNKNOWN) gfc_error ("Label %d referenced at %L is never defined", code->label1->value, &code->label1->where); if (t && (code->expr1->expr_type != EXPR_VARIABLE || code->expr1->symtree->n.sym->ts.type != BT_INTEGER || code->expr1->symtree->n.sym->ts.kind != gfc_default_integer_kind || code->expr1->symtree->n.sym->as != NULL)) gfc_error ("ASSIGN statement at %L requires a scalar " "default INTEGER variable", &code->expr1->where); break; case EXEC_POINTER_ASSIGN: { gfc_expr* e; if (!t) break; /* This is both a variable definition and pointer assignment context, so check both of them. For rank remapping, a final array ref may be present on the LHS and fool gfc_expr_attr used in gfc_check_vardef_context. Remove it. */ e = remove_last_array_ref (code->expr1); t = gfc_check_vardef_context (e, true, false, false, _("pointer assignment")); if (t) t = gfc_check_vardef_context (e, false, false, false, _("pointer assignment")); gfc_free_expr (e); t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; if (!t) break; /* Assigning a class object always is a regular assign. */ if (code->expr2->ts.type == BT_CLASS && code->expr1->ts.type == BT_CLASS && !CLASS_DATA (code->expr2)->attr.dimension && !(gfc_expr_attr (code->expr1).proc_pointer && code->expr2->expr_type == EXPR_VARIABLE && code->expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)) code->op = EXEC_ASSIGN; break; } case EXEC_ARITHMETIC_IF: { gfc_expr *e = code->expr1; gfc_resolve_expr (e); if (e->expr_type == EXPR_NULL) gfc_error ("Invalid NULL at %L", &e->where); if (t && (e->rank > 0 || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER))) gfc_error ("Arithmetic IF statement at %L requires a scalar " "REAL or INTEGER expression", &e->where); resolve_branch (code->label1, code); resolve_branch (code->label2, code); resolve_branch (code->label3, code); } break; case EXEC_IF: if (t && code->expr1 != NULL && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank != 0)) gfc_error ("IF clause at %L requires a scalar LOGICAL expression", &code->expr1->where); break; case EXEC_CALL: call: resolve_call (code); break; case EXEC_COMPCALL: compcall: resolve_typebound_subroutine (code); break; case EXEC_CALL_PPC: resolve_ppc_call (code); break; case EXEC_SELECT: /* Select is complicated. Also, a SELECT construct could be a transformed computed GOTO. */ resolve_select (code, false); break; case EXEC_SELECT_TYPE: resolve_select_type (code, ns); break; case EXEC_SELECT_RANK: resolve_select_rank (code, ns); break; case EXEC_BLOCK: resolve_block_construct (code); break; case EXEC_DO: if (code->ext.iterator != NULL) { gfc_iterator *iter = code->ext.iterator; if (gfc_resolve_iterator (iter, true, false)) gfc_resolve_do_iterator (code, iter->var->symtree->n.sym, true); } break; case EXEC_DO_WHILE: if (code->expr1 == NULL) gfc_internal_error ("gfc_resolve_code(): No expression on " "DO WHILE"); if (t && (code->expr1->rank != 0 || code->expr1->ts.type != BT_LOGICAL)) gfc_error ("Exit condition of DO WHILE loop at %L must be " "a scalar LOGICAL expression", &code->expr1->where); break; case EXEC_ALLOCATE: if (t) resolve_allocate_deallocate (code, "ALLOCATE"); break; case EXEC_DEALLOCATE: if (t) resolve_allocate_deallocate (code, "DEALLOCATE"); break; case EXEC_OPEN: if (!gfc_resolve_open (code->ext.open)) break; resolve_branch (code->ext.open->err, code); break; case EXEC_CLOSE: if (!gfc_resolve_close (code->ext.close)) break; resolve_branch (code->ext.close->err, code); break; case EXEC_BACKSPACE: case EXEC_ENDFILE: case EXEC_REWIND: case EXEC_FLUSH: if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) break; resolve_branch (code->ext.filepos->err, code); break; case EXEC_INQUIRE: if (!gfc_resolve_inquire (code->ext.inquire)) break; resolve_branch (code->ext.inquire->err, code); break; case EXEC_IOLENGTH: gcc_assert (code->ext.inquire != NULL); if (!gfc_resolve_inquire (code->ext.inquire)) break; resolve_branch (code->ext.inquire->err, code); break; case EXEC_WAIT: if (!gfc_resolve_wait (code->ext.wait)) break; resolve_branch (code->ext.wait->err, code); resolve_branch (code->ext.wait->end, code); resolve_branch (code->ext.wait->eor, code); break; case EXEC_READ: case EXEC_WRITE: if (!gfc_resolve_dt (code->ext.dt, &code->loc)) break; resolve_branch (code->ext.dt->err, code); resolve_branch (code->ext.dt->end, code); resolve_branch (code->ext.dt->eor, code); break; case EXEC_TRANSFER: resolve_transfer (code); break; case EXEC_DO_CONCURRENT: case EXEC_FORALL: resolve_forall_iterators (code->ext.forall_iterator); if (code->expr1 != NULL && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " "expression", &code->expr1->where); break; case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS_LOOP: case EXEC_OACC_KERNELS: case EXEC_OACC_SERIAL_LOOP: case EXEC_OACC_SERIAL: case EXEC_OACC_DATA: case EXEC_OACC_HOST_DATA: case EXEC_OACC_LOOP: case EXEC_OACC_UPDATE: case EXEC_OACC_WAIT: case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ATOMIC: case EXEC_OACC_DECLARE: gfc_resolve_oacc_directive (code, ns); break; case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_CRITICAL: case EXEC_OMP_FLUSH: case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_SIMD: case EXEC_OMP_DO: case EXEC_OMP_DO_SIMD: case EXEC_OMP_MASTER: case EXEC_OMP_ORDERED: case EXEC_OMP_SECTIONS: case EXEC_OMP_SIMD: case EXEC_OMP_SINGLE: case EXEC_OMP_TARGET: case EXEC_OMP_TARGET_DATA: case EXEC_OMP_TARGET_ENTER_DATA: case EXEC_OMP_TARGET_EXIT_DATA: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_SIMD: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TARGET_UPDATE: case EXEC_OMP_TASK: case EXEC_OMP_TASKGROUP: case EXEC_OMP_TASKLOOP: case EXEC_OMP_TASKLOOP_SIMD: case EXEC_OMP_TASKWAIT: case EXEC_OMP_TASKYIELD: case EXEC_OMP_TEAMS: case EXEC_OMP_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_WORKSHARE: gfc_resolve_omp_directive (code, ns); break; case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_DO_SIMD: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 0; gfc_resolve_omp_directive (code, ns); omp_workshare_flag = omp_workshare_save; break; default: gfc_internal_error ("gfc_resolve_code(): Bad statement code"); } } cs_base = frame.prev; } /* Resolve initial values and make sure they are compatible with the variable. */ static void resolve_values (gfc_symbol *sym) { bool t; if (sym->value == NULL) return; if (sym->value->expr_type == EXPR_STRUCTURE) t= resolve_structure_cons (sym->value, 1); else t = gfc_resolve_expr (sym->value); if (!t) return; gfc_check_assign_symbol (sym, NULL, sym->value); } /* Verify any BIND(C) derived types in the namespace so we can report errors for them once, rather than for each variable declared of that type. */ static void resolve_bind_c_derived_types (gfc_symbol *derived_sym) { if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED && derived_sym->attr.is_bind_c == 1) verify_bind_c_derived_type (derived_sym); return; } /* Check the interfaces of DTIO procedures associated with derived type 'sym'. These procedures can either have typebound bindings or can appear in DTIO generic interfaces. */ static void gfc_verify_DTIO_procedures (gfc_symbol *sym) { if (!sym || sym->attr.flavor != FL_DERIVED) return; gfc_check_dtio_interfaces (sym); return; } /* Verify that any binding labels used in a given namespace do not collide with the names or binding labels of any global symbols. Multiple INTERFACE for the same procedure are permitted. */ static void gfc_verify_binding_labels (gfc_symbol *sym) { gfc_gsymbol *gsym; const char *module; if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c || sym->attr.flavor == FL_DERIVED || !sym->binding_label) return; gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label); if (sym->module) module = sym->module; else if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE) module = sym->ns->proc_name->name; else if (sym->ns && sym->ns->parent && sym->ns && sym->ns->parent->proc_name && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) module = sym->ns->parent->proc_name->name; else module = NULL; if (!gsym || (!gsym->defined && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE))) { if (!gsym) gsym = gfc_get_gsymbol (sym->binding_label, true); gsym->where = sym->declared_at; gsym->sym_name = sym->name; gsym->binding_label = sym->binding_label; gsym->ns = sym->ns; gsym->mod_name = module; if (sym->attr.function) gsym->type = GSYM_FUNCTION; else if (sym->attr.subroutine) gsym->type = GSYM_SUBROUTINE; /* Mark as variable/procedure as defined, unless its an INTERFACE. */ gsym->defined = sym->attr.if_source != IFSRC_IFBODY; return; } if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) { gfc_error ("Variable %qs with binding label %qs at %L uses the same global " "identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); /* Clear the binding label to prevent checking multiple times. */ sym->binding_label = NULL; return; } if (sym->attr.flavor == FL_VARIABLE && module && (strcmp (module, gsym->mod_name) != 0 || strcmp (sym->name, gsym->sym_name) != 0)) { /* This can only happen if the variable is defined in a module - if it isn't the same module, reject it. */ gfc_error ("Variable %qs from module %qs with binding label %qs at %L " "uses the same global identifier as entity at %L from module %qs", sym->name, module, sym->binding_label, &sym->declared_at, &gsym->where, gsym->mod_name); sym->binding_label = NULL; return; } if ((sym->attr.function || sym->attr.subroutine) && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION) || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY)) && (sym != gsym->ns->proc_name && sym->attr.entry == 0) && (module != gsym->mod_name || strcmp (gsym->sym_name, sym->name) != 0 || (module && strcmp (module, gsym->mod_name) != 0))) { /* Print an error if the procedure is defined multiple times; we have to exclude references to the same procedure via module association or multiple checks for the same procedure. */ gfc_error ("Procedure %qs with binding label %qs at %L uses the same " "global identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label = NULL; } } /* Resolve an index expression. */ static bool resolve_index_expr (gfc_expr *e) { if (!gfc_resolve_expr (e)) return false; if (!gfc_simplify_expr (e, 0)) return false; if (!gfc_specification_expr (e)) return false; return true; } /* Resolve a charlen structure. */ static bool resolve_charlen (gfc_charlen *cl) { int k; bool saved_specification_expr; if (cl->resolved) return true; cl->resolved = 1; saved_specification_expr = specification_expr; specification_expr = true; if (cl->length_from_typespec) { if (!gfc_resolve_expr (cl->length)) { specification_expr = saved_specification_expr; return false; } if (!gfc_simplify_expr (cl->length, 0)) { specification_expr = saved_specification_expr; return false; } /* cl->length has been resolved. It should have an integer type. */ if (cl->length->ts.type != BT_INTEGER) { gfc_error ("Scalar INTEGER expression expected at %L", &cl->length->where); return false; } } else { if (!resolve_index_expr (cl->length)) { specification_expr = saved_specification_expr; return false; } } /* F2008, 4.4.3.2: If the character length parameter value evaluates to a negative value, the length of character entities declared is zero. */ if (cl->length && cl->length->expr_type == EXPR_CONSTANT && mpz_sgn (cl->length->value.integer) < 0) gfc_replace_expr (cl->length, gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); /* Check that the character length is not too large. */ k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); if (cl->length && cl->length->expr_type == EXPR_CONSTANT && cl->length->ts.type == BT_INTEGER && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0) { gfc_error ("String length at %L is too large", &cl->length->where); specification_expr = saved_specification_expr; return false; } specification_expr = saved_specification_expr; return true; } /* Test for non-constant shape arrays. */ static bool is_non_constant_shape_array (gfc_symbol *sym) { gfc_expr *e; int i; bool not_constant; not_constant = false; if (sym->as != NULL) { /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that has not been simplified; parameter array references. Do the simplification now. */ for (i = 0; i < sym->as->rank + sym->as->corank; i++) { if (i == GFC_MAX_DIMENSIONS) break; e = sym->as->lower[i]; if (e && (!resolve_index_expr(e) || !gfc_is_constant_expr (e))) not_constant = true; e = sym->as->upper[i]; if (e && (!resolve_index_expr(e) || !gfc_is_constant_expr (e))) not_constant = true; } } return not_constant; } /* Given a symbol and an initialization expression, add code to initialize the symbol to the function entry. */ static void build_init_assign (gfc_symbol *sym, gfc_expr *init) { gfc_expr *lval; gfc_code *init_st; gfc_namespace *ns = sym->ns; /* Search for the function namespace if this is a contained function without an explicit result. */ if (sym->attr.function && sym == sym->result && sym->name != sym->ns->proc_name->name) { ns = ns->contained; for (;ns; ns = ns->sibling) if (strcmp (ns->proc_name->name, sym->name) == 0) break; } if (ns == NULL) { gfc_free_expr (init); return; } /* Build an l-value expression for the result. */ lval = gfc_lval_expr_from_sym (sym); /* Add the code at scope entry. */ init_st = gfc_get_code (EXEC_INIT_ASSIGN); init_st->next = ns->code; ns->code = init_st; /* Assign the default initializer to the l-value. */ init_st->loc = sym->declared_at; init_st->expr1 = lval; init_st->expr2 = init; } /* Whether or not we can generate a default initializer for a symbol. */ static bool can_generate_init (gfc_symbol *sym) { symbol_attribute *a; if (!sym) return false; a = &sym->attr; /* These symbols should never have a default initialization. */ return !( a->allocatable || a->external || a->pointer || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.class_pointer || CLASS_DATA (sym)->attr.proc_pointer)) || a->in_equivalence || a->in_common || a->data || sym->module || a->cray_pointee || a->cray_pointer || sym->assoc || (!a->referenced && !a->result) || (a->dummy && a->intent != INTENT_OUT) || (a->function && sym != sym->result) ); } /* Assign the default initializer to a derived type variable or result. */ static void apply_default_init (gfc_symbol *sym) { gfc_expr *init = NULL; if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) return; if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) init = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); if (init == NULL && sym->ts.type != BT_CLASS) return; build_init_assign (sym, init); sym->attr.referenced = 1; } /* Build an initializer for a local. Returns null if the symbol should not have a default initialization. */ static gfc_expr * build_default_init_expr (gfc_symbol *sym) { /* These symbols should never have a default initialization. */ if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.pointer || sym->attr.in_equivalence || sym->attr.in_common || sym->attr.data || sym->module || sym->attr.cray_pointee || sym->attr.cray_pointer || sym->assoc) return NULL; /* Get the appropriate init expression. */ return gfc_build_default_init_expr (&sym->ts, &sym->declared_at); } /* Add an initialization expression to a local variable. */ static void apply_default_init_local (gfc_symbol *sym) { gfc_expr *init = NULL; /* The symbol should be a variable or a function return value. */ if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function) || (sym->attr.function && sym->result != sym)) return; /* Try to build the initializer expression. If we can't initialize this symbol, then init will be NULL. */ init = build_default_init_expr (sym); if (init == NULL) return; /* For saved variables, we don't want to add an initializer at function entry, so we just add a static initializer. Note that automatic variables are stack allocated even with -fno-automatic; we have also to exclude result variable, which are also nonstatic. */ if (!sym->attr.automatic && (sym->attr.save || sym->ns->save_all || (flag_max_stack_var_size == 0 && !sym->attr.result && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))) { /* Don't clobber an existing initializer! */ gcc_assert (sym->value == NULL); sym->value = init; return; } build_init_assign (sym, init); } /* Resolution of common features of flavors variable and procedure. */ static bool resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_array_spec *as; if (sym->ts.type == BT_CLASS && sym->attr.class_ok) as = CLASS_DATA (sym)->as; else as = sym->as; /* Constraints on deferred shape variable. */ if (as == NULL || as->type != AS_DEFERRED) { bool pointer, allocatable, dimension; if (sym->ts.type == BT_CLASS && sym->attr.class_ok) { pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; dimension = CLASS_DATA (sym)->attr.dimension; } else { pointer = sym->attr.pointer && !sym->attr.select_type_temporary; allocatable = sym->attr.allocatable; dimension = sym->attr.dimension; } if (allocatable) { if (dimension && as->type != AS_ASSUMED_RANK) { gfc_error ("Allocatable array %qs at %L must have a deferred " "shape or assumed rank", sym->name, &sym->declared_at); return false; } else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " "%qs at %L may not be ALLOCATABLE", sym->name, &sym->declared_at)) return false; } if (pointer && dimension && as->type != AS_ASSUMED_RANK) { gfc_error ("Array pointer %qs at %L must have a deferred shape or " "assumed rank", sym->name, &sym->declared_at); return false; } } else { if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer && sym->ts.type != BT_CLASS && !sym->assoc) { gfc_error ("Array %qs at %L cannot have a deferred shape", sym->name, &sym->declared_at); return false; } } /* Constraints on polymorphic variables. */ if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) { /* F03:C502. */ if (sym->attr.class_ok && !sym->attr.select_type_temporary && !UNLIMITED_POLY (sym) && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible", CLASS_DATA (sym)->ts.u.derived->name, sym->name, &sym->declared_at); return false; } /* F03:C509. */ /* Assume that use associated symbols were checked in the module ns. Class-variables that are associate-names are also something special and excepted from the test. */ if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc) { gfc_error ("CLASS variable %qs at %L must be dummy, allocatable " "or pointer", sym->name, &sym->declared_at); return false; } } return true; } /* Additional checks for symbols with flavor variable and derived type. To be called from resolve_fl_variable. */ static bool resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); /* Check to see if a derived type is blocked from being host associated by the presence of another class I symbol in the same namespace. 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */ if (sym->ns != sym->ts.u.derived->ns && !sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) { gfc_symbol *s; gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); if (s && s->attr.generic) s = gfc_find_dt_in_generic (s); if (s && !gfc_fl_struct (s->attr.flavor)) { gfc_error ("The type %qs cannot be host associated at %L " "because it is blocked by an incompatible object " "of the same name declared at %L", sym->ts.u.derived->name, &sym->declared_at, &s->declared_at); return false; } } /* 4th constraint in section 11.3: "If an object of a type for which component-initialization is specified (R429) appears in the specification-part of a module and does not have the ALLOCATABLE or POINTER attribute, the object shall have the SAVE attribute." The check for initializers is performed with gfc_has_default_initializer because gfc_default_initializer generates a hidden default for allocatable components. */ if (!(sym->value || no_init_flag) && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable && gfc_has_default_initializer (sym->ts.u.derived) && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " "%qs at %L, needed due to the default " "initialization", sym->name, &sym->declared_at)) return false; /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) && (!no_init_flag || sym->attr.intent == INTENT_OUT)) sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); return true; } /* F2008, C402 (R401): A colon shall not be used as a type-param-value except in the declaration of an entity or component that has the POINTER or ALLOCATABLE attribute. */ static bool deferred_requirements (gfc_symbol *sym) { if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable || sym->attr.associate_var || sym->attr.omp_udr_artificial_var)) { /* If a function has a result variable, only check the variable. */ if (sym->result && sym->name != sym->result->name) return true; gfc_error ("Entity %qs at %L has a deferred type parameter and " "requires either the POINTER or ALLOCATABLE attribute", sym->name, &sym->declared_at); return false; } return true; } /* Resolve symbols with flavor variable. */ static bool resolve_fl_variable (gfc_symbol *sym, int mp_flag) { const char *auto_save_msg = "Automatic object %qs at %L cannot have the " "SAVE attribute"; if (!resolve_fl_var_and_proc (sym, mp_flag)) return false; /* Set this flag to check that variables are parameters of all entries. This check is effected by the call to gfc_resolve_expr through is_non_constant_shape_array. */ bool saved_specification_expr = specification_expr; specification_expr = true; if (sym->ns->proc_name && (sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program) && !sym->attr.use_assoc && !sym->attr.allocatable && !sym->attr.pointer && is_non_constant_shape_array (sym)) { /* F08:C541. The shape of an array defined in a main program or module * needs to be constant. */ gfc_error ("The module or main program array %qs at %L must " "have constant shape", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } /* Constraints on deferred type parameter. */ if (!deferred_requirements (sym)) return false; if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var) { /* Make sure that character string variables with assumed length are dummy arguments. */ gfc_expr *e = NULL; if (sym->ts.u.cl) e = sym->ts.u.cl->length; else return false; if (e == NULL && !sym->attr.dummy && !sym->attr.result && !sym->ts.deferred && !sym->attr.select_type_temporary && !sym->attr.omp_udr_artificial_var) { gfc_error ("Entity with assumed character length at %L must be a " "dummy argument or a PARAMETER", &sym->declared_at); specification_expr = saved_specification_expr; return false; } if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } if (!gfc_is_constant_expr (e) && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) { if (!sym->attr.use_assoc && sym->ns->proc_name && (sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program)) { gfc_error ("%qs at %L must have constant character length " "in this context", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } if (sym->attr.in_common) { gfc_error ("COMMON variable %qs at %L must have constant " "character length", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } } } if (sym->value == NULL && sym->attr.referenced) apply_default_init_local (sym); /* Try to apply a default initialization. */ /* Determine if the symbol may not have an initializer. */ int no_init_flag = 0, automatic_flag = 0; if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.intrinsic || sym->attr.result) no_init_flag = 1; else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer && is_non_constant_shape_array (sym)) { no_init_flag = automatic_flag = 1; /* Also, they must not have the SAVE attribute. SAVE_IMPLICIT is checked below. */ if (sym->as && sym->attr.codimension) { int corank = sym->as->corank; sym->as->corank = 0; no_init_flag = automatic_flag = is_non_constant_shape_array (sym); sym->as->corank = corank; } if (automatic_flag && sym->attr.save == SAVE_EXPLICIT) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } } /* Ensure that any initializer is simplified. */ if (sym->value) gfc_simplify_expr (sym->value, 1); /* Reject illegal initializers. */ if (!sym->mark && sym->value) { if (sym->attr.allocatable || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable)) gfc_error ("Allocatable %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.external) gfc_error ("External %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.dummy && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT)) gfc_error ("Dummy %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.intrinsic) gfc_error ("Intrinsic %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.result) gfc_error ("Function result %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (automatic_flag) gfc_error ("Automatic array %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else goto no_init_error; specification_expr = saved_specification_expr; return false; } no_init_error: if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) { bool res = resolve_fl_variable_derived (sym, no_init_flag); specification_expr = saved_specification_expr; return res; } specification_expr = saved_specification_expr; return true; } /* Compare the dummy characteristics of a module procedure interface declaration with the corresponding declaration in a submodule. */ static gfc_formal_arglist *new_formal; static char errmsg[200]; static void compare_fsyms (gfc_symbol *sym) { gfc_symbol *fsym; if (sym == NULL || new_formal == NULL) return; fsym = new_formal->sym; if (sym == fsym) return; if (strcmp (sym->name, fsym->name) == 0) { if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200)) gfc_error ("%s at %L", errmsg, &fsym->declared_at); } } /* Resolve a procedure. */ static bool resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_formal_arglist *arg; if (sym->attr.function && !resolve_fl_var_and_proc (sym, mp_flag)) return false; /* Constraints on deferred type parameter. */ if (!deferred_requirements (sym)) return false; if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; if (cl && cl->length && gfc_is_constant_expr (cl->length) && !resolve_charlen (cl)) return false; if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) && sym->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Character-valued statement function %qs at %L must " "have constant length", sym->name, &sym->declared_at); return false; } } /* Ensure that derived type for are not of a private type. Internal module procedures are excluded by 2.2.3.3 - i.e., they are not externally accessible and can access all the objects accessible in the host. */ if (!(sym->ns->parent && sym->ns->parent->proc_name && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) && gfc_check_symbol_access (sym)) { gfc_interface *iface; for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next) { if (arg->sym && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " "and cannot be a dummy argument" " of %qs, which is PUBLIC at %L", arg->sym->name, sym->name, &sym->declared_at)) { /* Stop this message from recurring. */ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; return false; } } /* PUBLIC interfaces may expose PRIVATE procedures that take types PRIVATE to the containing module. */ for (iface = sym->generic; iface; iface = iface->next) { for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next) { if (arg->sym && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in " "PUBLIC interface %qs at %L " "takes dummy arguments of %qs which " "is PRIVATE", iface->sym->name, sym->name, &iface->sym->declared_at, gfc_typename(&arg->sym->ts))) { /* Stop this message from recurring. */ arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; return false; } } } } if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION && !sym->attr.proc_pointer) { gfc_error ("Function %qs at %L cannot have an initializer", sym->name, &sym->declared_at); /* Make sure no second error is issued for this. */ sym->value->error = 1; return false; } /* An external symbol may not have an initializer because it is taken to be a procedure. Exception: Procedure Pointers. */ if (sym->attr.external && sym->value && !sym->attr.proc_pointer) { gfc_error ("External object %qs at %L may not have an initializer", sym->name, &sym->declared_at); return false; } /* An elemental function is required to return a scalar 12.7.1 */ if (sym->attr.elemental && sym->attr.function && (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))) { gfc_error ("ELEMENTAL function %qs at %L must have a scalar " "result", sym->name, &sym->declared_at); /* Reset so that the error only occurs once. */ sym->attr.elemental = 0; return false; } if (sym->attr.proc == PROC_ST_FUNCTION && (sym->attr.allocatable || sym->attr.pointer)) { gfc_error ("Statement function %qs at %L may not have pointer or " "allocatable attribute", sym->name, &sym->declared_at); return false; } /* 5.1.1.5 of the Standard: A function name declared with an asterisk char-len-param shall not be array-valued, pointer-valued, recursive or pure. ....snip... A character value of * may only be used in the following ways: (i) Dummy arg of procedure - dummy associates with actual length; (ii) To declare a named constant; or (iii) External function - but length must be declared in calling scoping unit. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER && !sym->ts.deferred && sym->ts.u.cl && sym->ts.u.cl->length == NULL) { if ((sym->as && sym->as->rank) || (sym->attr.pointer) || (sym->attr.recursive) || (sym->attr.pure)) { if (sym->as && sym->as->rank) gfc_error ("CHARACTER(*) function %qs at %L cannot be " "array-valued", sym->name, &sym->declared_at); if (sym->attr.pointer) gfc_error ("CHARACTER(*) function %qs at %L cannot be " "pointer-valued", sym->name, &sym->declared_at); if (sym->attr.pure) gfc_error ("CHARACTER(*) function %qs at %L cannot be " "pure", sym->name, &sym->declared_at); if (sym->attr.recursive) gfc_error ("CHARACTER(*) function %qs at %L cannot be " "recursive", sym->name, &sym->declared_at); return false; } /* Appendix B.2 of the standard. Contained functions give an error anyway. Deferred character length is an F2003 feature. Don't warn on intrinsic conversion functions, which start with two underscores. */ if (!sym->attr.contained && !sym->ts.deferred && (sym->name[0] != '_' || sym->name[1] != '_')) gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function %qs at %L", sym->name, &sym->declared_at); } /* F2008, C1218. */ if (sym->attr.elemental) { if (sym->attr.proc_pointer) { gfc_error ("Procedure pointer %qs at %L shall not be elemental", sym->name, &sym->declared_at); return false; } if (sym->attr.dummy) { gfc_error ("Dummy procedure %qs at %L shall not be elemental", sym->name, &sym->declared_at); return false; } } /* F2018, C15100: "The result of an elemental function shall be scalar, and shall not have the POINTER or ALLOCATABLE attribute." The scalar pointer is tested and caught elsewhere. */ if (sym->attr.elemental && sym->result && (sym->result->attr.allocatable || sym->result->attr.pointer)) { gfc_error ("Function result variable %qs at %L of elemental " "function %qs shall not have an ALLOCATABLE or POINTER " "attribute", sym->result->name, &sym->result->declared_at, sym->name); return false; } if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) { gfc_formal_arglist *curr_arg; int has_non_interop_arg = 0; if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, sym->common_block)) { /* Clear these to prevent looking at them again if there was an error. */ sym->attr.is_bind_c = 0; sym->attr.is_c_interop = 0; sym->ts.is_c_interop = 0; } else { /* So far, no errors have been found. */ sym->attr.is_c_interop = 1; sym->ts.is_c_interop = 1; } curr_arg = gfc_sym_get_dummy_args (sym); while (curr_arg != NULL) { /* Skip implicitly typed dummy args here. */ if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0) if (!gfc_verify_c_interop_param (curr_arg->sym)) /* If something is found to fail, record the fact so we can mark the symbol for the procedure as not being BIND(C) to try and prevent multiple errors being reported. */ has_non_interop_arg = 1; curr_arg = curr_arg->next; } /* See if any of the arguments were not interoperable and if so, clear the procedure symbol to prevent duplicate error messages. */ if (has_non_interop_arg != 0) { sym->attr.is_c_interop = 0; sym->ts.is_c_interop = 0; sym->attr.is_bind_c = 0; } } if (!sym->attr.proc_pointer) { if (sym->attr.save == SAVE_EXPLICIT) { gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " "in %qs at %L", sym->name, &sym->declared_at); return false; } if (sym->attr.intent) { gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " "in %qs at %L", sym->name, &sym->declared_at); return false; } if (sym->attr.subroutine && sym->attr.result) { gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " "in %qs at %L", sym->name, &sym->declared_at); return false; } if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) || sym->attr.contained)) { gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " "in %qs at %L", sym->name, &sym->declared_at); return false; } if (strcmp ("ppr@", sym->name) == 0) { gfc_error ("Procedure pointer result %qs at %L " "is missing the pointer attribute", sym->ns->proc_name->name, &sym->declared_at); return false; } } /* Assume that a procedure whose body is not known has references to external arrays. */ if (sym->attr.if_source != IFSRC_DECL) sym->attr.array_outer_dependency = 1; /* Compare the characteristics of a module procedure with the interface declaration. Ideally this would be done with gfc_compare_interfaces but, at present, the formal interface cannot be copied to the ts.interface. */ if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_DECL) { gfc_symbol *iface; char name[2*GFC_MAX_SYMBOL_LEN + 1]; char *module_name; char *submodule_name; strcpy (name, sym->ns->proc_name->name); module_name = strtok (name, "."); submodule_name = strtok (NULL, "."); iface = sym->tlink; sym->tlink = NULL; /* Make sure that the result uses the correct charlen for deferred length results. */ if (iface && sym->result && iface->ts.type == BT_CHARACTER && iface->ts.deferred) sym->result->ts.u.cl = iface->ts.u.cl; if (iface == NULL) goto check_formal; /* Check the procedure characteristics. */ if (sym->attr.elemental != iface->attr.elemental) { gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " "PROCEDURE at %L and its interface in %s", &sym->declared_at, module_name); return false; } if (sym->attr.pure != iface->attr.pure) { gfc_error ("Mismatch in PURE attribute between MODULE " "PROCEDURE at %L and its interface in %s", &sym->declared_at, module_name); return false; } if (sym->attr.recursive != iface->attr.recursive) { gfc_error ("Mismatch in RECURSIVE attribute between MODULE " "PROCEDURE at %L and its interface in %s", &sym->declared_at, module_name); return false; } /* Check the result characteristics. */ if (!gfc_check_result_characteristics (sym, iface, errmsg, 200)) { gfc_error ("%s between the MODULE PROCEDURE declaration " "in MODULE %qs and the declaration at %L in " "(SUB)MODULE %qs", errmsg, module_name, &sym->declared_at, submodule_name ? submodule_name : module_name); return false; } check_formal: /* Check the characteristics of the formal arguments. */ if (sym->formal && sym->formal_ns) { for (arg = sym->formal; arg && arg->sym; arg = arg->next) { new_formal = arg; gfc_traverse_ns (sym->formal_ns, compare_fsyms); } } } return true; } /* Resolve a list of finalizer procedures. That is, after they have hopefully been defined and we now know their defined arguments, check that they fulfill the requirements of the standard for procedures used as finalizers. */ static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { gfc_finalizer* list; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; gfc_symbol *vtab; gfc_component *c; gfc_symbol *parent = gfc_get_derived_super_type (derived); if (parent) gfc_resolve_finalizers (parent, finalizable); /* Ensure that derived-type components have a their finalizers resolved. */ bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers; for (c = derived->components; c; c = c->next) if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) { bool has_final2 = false; if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2)) return false; /* Error. */ has_final = has_final || has_final2; } /* Return early if not finalizable. */ if (!has_final) { if (finalizable) *finalizable = false; return true; } /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ prev_link = &derived->f2k_derived->finalizers; for (list = derived->f2k_derived->finalizers; list; list = *prev_link) { gfc_formal_arglist *dummy_args; gfc_symbol* arg; gfc_finalizer* i; int my_rank; /* Skip this finalizer if we already resolved it. */ if (list->proc_tree) { if (list->proc_tree->n.sym->formal->sym->as == NULL || list->proc_tree->n.sym->formal->sym->as->rank == 0) seen_scalar = true; prev_link = &(list->next); continue; } /* Check this exists and is a SUBROUTINE. */ if (!list->proc_sym->attr.subroutine) { gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE", list->proc_sym->name, &list->where); goto error; } /* We should have exactly one argument. */ dummy_args = gfc_sym_get_dummy_args (list->proc_sym); if (!dummy_args || dummy_args->next) { gfc_error ("FINAL procedure at %L must have exactly one argument", &list->where); goto error; } arg = dummy_args->sym; /* This argument must be of our type. */ if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); goto error; } /* It must neither be a pointer nor allocatable nor optional. */ if (arg->attr.pointer) { gfc_error ("Argument of FINAL procedure at %L must not be a POINTER", &arg->declared_at); goto error; } if (arg->attr.allocatable) { gfc_error ("Argument of FINAL procedure at %L must not be" " ALLOCATABLE", &arg->declared_at); goto error; } if (arg->attr.optional) { gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL", &arg->declared_at); goto error; } /* It must not be INTENT(OUT). */ if (arg->attr.intent == INTENT_OUT) { gfc_error ("Argument of FINAL procedure at %L must not be" " INTENT(OUT)", &arg->declared_at); goto error; } /* Warn if the procedure is non-scalar and not assumed shape. */ if (warn_surprising && arg->as && arg->as->rank != 0 && arg->as->type != AS_ASSUMED_SHAPE) gfc_warning (OPT_Wsurprising, "Non-scalar FINAL procedure at %L should have assumed" " shape argument", &arg->declared_at); /* Check that it does not match in kind and rank with a FINAL procedure defined earlier. To really loop over the *earlier* declarations, we need to walk the tail of the list as new ones were pushed at the front. */ /* TODO: Handle kind parameters once they are implemented. */ my_rank = (arg->as ? arg->as->rank : 0); for (i = list->next; i; i = i->next) { gfc_formal_arglist *dummy_args; /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); if (dummy_args) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); if (i_rank == my_rank) { gfc_error ("FINAL procedure %qs declared at %L has the same" " rank (%d) as %qs", list->proc_sym->name, &list->where, my_rank, i->proc_sym->name); goto error; } } } /* Is this the/a scalar finalizer procedure? */ if (my_rank == 0) seen_scalar = true; /* Find the symtree for this procedure. */ gcc_assert (!list->proc_tree); list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); prev_link = &list->next; continue; /* Remove wrong nodes immediately from the list so we don't risk any troubles in the future when they might fail later expectations. */ error: i = list; *prev_link = list->next; gfc_free_finalizer (i); result = false; } if (result == false) return false; /* Warn if we haven't seen a scalar finalizer procedure (but we know there were nodes in the list, must have been for arrays. It is surely a good idea to have a scalar version there if there's something to finalize. */ if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar) gfc_warning (OPT_Wsurprising, "Only array FINAL procedures declared for derived type %qs" " defined at %L, suggest also scalar one", derived->name, &derived->declared_at); vtab = gfc_find_derived_vtab (derived); c = vtab->ts.u.derived->components->next->next->next->next->next; gfc_set_sym_referenced (c->initializer->symtree->n.sym); if (finalizable) *finalizable = true; return true; } /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ static bool check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, const char* generic_name, locus where) { gfc_symbol *sym1, *sym2; const char *pass1, *pass2; gfc_formal_arglist *dummy_args; gcc_assert (t1->specific && t2->specific);