Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/openmp.c @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
1 /* OpenMP directive matching and resolving. 1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2018 Free Software Foundation, Inc. 2 Copyright (C) 2005-2020 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek 3 Contributed by Jakub Jelinek
4 4
5 This file is part of GCC. 5 This file is part of GCC.
6 6
7 GCC is free software; you can redistribute it and/or modify it under 7 GCC is free software; you can redistribute it and/or modify it under
29 #include "gomp-constants.h" 29 #include "gomp-constants.h"
30 30
31 /* Match an end of OpenMP directive. End of OpenMP directive is optional 31 /* Match an end of OpenMP directive. End of OpenMP directive is optional
32 whitespace, followed by '\n' or comment '!'. */ 32 whitespace, followed by '\n' or comment '!'. */
33 33
34 match 34 static match
35 gfc_match_omp_eos (void) 35 gfc_match_omp_eos (void)
36 { 36 {
37 locus old_loc; 37 locus old_loc;
38 char c; 38 char c;
39 39
54 } 54 }
55 55
56 gfc_current_locus = old_loc; 56 gfc_current_locus = old_loc;
57 return MATCH_NO; 57 return MATCH_NO;
58 } 58 }
59
60 match
61 gfc_match_omp_eos_error (void)
62 {
63 if (gfc_match_omp_eos() == MATCH_YES)
64 return MATCH_YES;
65
66 gfc_error ("Unexpected junk at %C");
67 return MATCH_ERROR;
68 }
69
59 70
60 /* Free an omp_clauses structure. */ 71 /* Free an omp_clauses structure. */
61 72
62 void 73 void
63 gfc_free_omp_clauses (gfc_omp_clauses *c) 74 gfc_free_omp_clauses (gfc_omp_clauses *c)
220 231
221 static match 232 static match
222 gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, 233 gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
223 bool allow_common, bool *end_colon = NULL, 234 bool allow_common, bool *end_colon = NULL,
224 gfc_omp_namelist ***headp = NULL, 235 gfc_omp_namelist ***headp = NULL,
225 bool allow_sections = false) 236 bool allow_sections = false,
237 bool allow_derived = false)
226 { 238 {
227 gfc_omp_namelist *head, *tail, *p; 239 gfc_omp_namelist *head, *tail, *p;
228 locus old_loc, cur_loc; 240 locus old_loc, cur_loc;
229 char n[GFC_MAX_SYMBOL_LEN+1]; 241 char n[GFC_MAX_SYMBOL_LEN+1];
230 gfc_symbol *sym; 242 gfc_symbol *sym;
246 switch (m) 258 switch (m)
247 { 259 {
248 case MATCH_YES: 260 case MATCH_YES:
249 gfc_expr *expr; 261 gfc_expr *expr;
250 expr = NULL; 262 expr = NULL;
251 if (allow_sections && gfc_peek_ascii_char () == '(') 263 if ((allow_sections && gfc_peek_ascii_char () == '(')
264 || (allow_derived && gfc_peek_ascii_char () == '%'))
252 { 265 {
253 gfc_current_locus = cur_loc; 266 gfc_current_locus = cur_loc;
254 m = gfc_match_variable (&expr, 0); 267 m = gfc_match_variable (&expr, 0);
255 switch (m) 268 switch (m)
256 { 269 {
258 goto cleanup; 271 goto cleanup;
259 case MATCH_NO: 272 case MATCH_NO:
260 goto syntax; 273 goto syntax;
261 default: 274 default:
262 break; 275 break;
276 }
277 if (gfc_is_coindexed (expr))
278 {
279 gfc_error ("List item shall not be coindexed at %C");
280 goto cleanup;
263 } 281 }
264 } 282 }
265 gfc_set_sym_referenced (sym); 283 gfc_set_sym_referenced (sym);
266 p = gfc_get_omp_namelist (); 284 p = gfc_get_omp_namelist ();
267 if (head == NULL) 285 if (head == NULL)
778 OMP_CLAUSE_NUM_TASKS, 796 OMP_CLAUSE_NUM_TASKS,
779 OMP_CLAUSE_PRIORITY, 797 OMP_CLAUSE_PRIORITY,
780 OMP_CLAUSE_SIMD, 798 OMP_CLAUSE_SIMD,
781 OMP_CLAUSE_THREADS, 799 OMP_CLAUSE_THREADS,
782 OMP_CLAUSE_USE_DEVICE_PTR, 800 OMP_CLAUSE_USE_DEVICE_PTR,
801 OMP_CLAUSE_USE_DEVICE_ADDR, /* Actually, OpenMP 5.0. */
783 OMP_CLAUSE_NOWAIT, 802 OMP_CLAUSE_NOWAIT,
784 /* This must come last. */ 803 /* This must come last. */
785 OMP_MASK1_LAST 804 OMP_MASK1_LAST
786 }; 805 };
787 806
788 /* OpenACC 2.0 specific clauses. */ 807 /* OpenACC 2.0+ specific clauses. */
789 enum omp_mask2 808 enum omp_mask2
790 { 809 {
791 OMP_CLAUSE_ASYNC, 810 OMP_CLAUSE_ASYNC,
792 OMP_CLAUSE_NUM_GANGS, 811 OMP_CLAUSE_NUM_GANGS,
793 OMP_CLAUSE_NUM_WORKERS, 812 OMP_CLAUSE_NUM_WORKERS,
794 OMP_CLAUSE_VECTOR_LENGTH, 813 OMP_CLAUSE_VECTOR_LENGTH,
795 OMP_CLAUSE_COPY, 814 OMP_CLAUSE_COPY,
796 OMP_CLAUSE_COPYOUT, 815 OMP_CLAUSE_COPYOUT,
797 OMP_CLAUSE_CREATE, 816 OMP_CLAUSE_CREATE,
817 OMP_CLAUSE_NO_CREATE,
798 OMP_CLAUSE_PRESENT, 818 OMP_CLAUSE_PRESENT,
799 OMP_CLAUSE_DEVICEPTR, 819 OMP_CLAUSE_DEVICEPTR,
800 OMP_CLAUSE_GANG, 820 OMP_CLAUSE_GANG,
801 OMP_CLAUSE_WORKER, 821 OMP_CLAUSE_WORKER,
802 OMP_CLAUSE_VECTOR, 822 OMP_CLAUSE_VECTOR,
809 OMP_CLAUSE_DELETE, 829 OMP_CLAUSE_DELETE,
810 OMP_CLAUSE_AUTO, 830 OMP_CLAUSE_AUTO,
811 OMP_CLAUSE_TILE, 831 OMP_CLAUSE_TILE,
812 OMP_CLAUSE_IF_PRESENT, 832 OMP_CLAUSE_IF_PRESENT,
813 OMP_CLAUSE_FINALIZE, 833 OMP_CLAUSE_FINALIZE,
834 OMP_CLAUSE_ATTACH,
835 OMP_CLAUSE_DETACH,
814 /* This must come last. */ 836 /* This must come last. */
815 OMP_MASK2_LAST 837 OMP_MASK2_LAST
816 }; 838 };
817 839
818 struct omp_inv_mask; 840 struct omp_inv_mask;
912 934
913 /* Helper function for OpenACC and OpenMP clauses involving memory 935 /* Helper function for OpenACC and OpenMP clauses involving memory
914 mapping. */ 936 mapping. */
915 937
916 static bool 938 static bool
917 gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) 939 gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
940 bool allow_common, bool allow_derived)
918 { 941 {
919 gfc_omp_namelist **head = NULL; 942 gfc_omp_namelist **head = NULL;
920 if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) 943 if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
944 allow_derived)
921 == MATCH_YES) 945 == MATCH_YES)
922 { 946 {
923 gfc_omp_namelist *n; 947 gfc_omp_namelist *n;
924 for (n = *head; n; n = n->next) 948 for (n = *head; n; n = n->next)
925 n->u.map_op = map_op; 949 n->u.map_op = map_op;
937 bool first = true, bool needs_space = true, 961 bool first = true, bool needs_space = true,
938 bool openacc = false) 962 bool openacc = false)
939 { 963 {
940 gfc_omp_clauses *c = gfc_get_omp_clauses (); 964 gfc_omp_clauses *c = gfc_get_omp_clauses ();
941 locus old_loc; 965 locus old_loc;
966 /* Determine whether we're dealing with an OpenACC directive that permits
967 derived type member accesses. This in particular disallows
968 "!$acc declare" from using such accesses, because it's not clear if/how
969 that should work. */
970 bool allow_derived = (openacc
971 && ((mask & OMP_CLAUSE_ATTACH)
972 || (mask & OMP_CLAUSE_DETACH)
973 || (mask & OMP_CLAUSE_HOST_SELF)));
942 974
943 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); 975 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
944 *cp = NULL; 976 *cp = NULL;
945 while (1) 977 while (1)
946 { 978 {
1010 { 1042 {
1011 c->par_auto = true; 1043 c->par_auto = true;
1012 needs_space = true; 1044 needs_space = true;
1013 continue; 1045 continue;
1014 } 1046 }
1047 if ((mask & OMP_CLAUSE_ATTACH)
1048 && gfc_match ("attach ( ") == MATCH_YES
1049 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1050 OMP_MAP_ATTACH, false,
1051 allow_derived))
1052 continue;
1015 break; 1053 break;
1016 case 'c': 1054 case 'c':
1017 if ((mask & OMP_CLAUSE_COLLAPSE) 1055 if ((mask & OMP_CLAUSE_COLLAPSE)
1018 && !c->collapse) 1056 && !c->collapse)
1019 { 1057 {
1037 } 1075 }
1038 } 1076 }
1039 if ((mask & OMP_CLAUSE_COPY) 1077 if ((mask & OMP_CLAUSE_COPY)
1040 && gfc_match ("copy ( ") == MATCH_YES 1078 && gfc_match ("copy ( ") == MATCH_YES
1041 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1079 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1042 OMP_MAP_TOFROM)) 1080 OMP_MAP_TOFROM, true,
1081 allow_derived))
1043 continue; 1082 continue;
1044 if (mask & OMP_CLAUSE_COPYIN) 1083 if (mask & OMP_CLAUSE_COPYIN)
1045 { 1084 {
1046 if (openacc) 1085 if (openacc)
1047 { 1086 {
1048 if (gfc_match ("copyin ( ") == MATCH_YES 1087 if (gfc_match ("copyin ( ") == MATCH_YES
1049 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1088 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1050 OMP_MAP_TO)) 1089 OMP_MAP_TO, true,
1090 allow_derived))
1051 continue; 1091 continue;
1052 } 1092 }
1053 else if (gfc_match_omp_variable_list ("copyin (", 1093 else if (gfc_match_omp_variable_list ("copyin (",
1054 &c->lists[OMP_LIST_COPYIN], 1094 &c->lists[OMP_LIST_COPYIN],
1055 true) == MATCH_YES) 1095 true) == MATCH_YES)
1056 continue; 1096 continue;
1057 } 1097 }
1058 if ((mask & OMP_CLAUSE_COPYOUT) 1098 if ((mask & OMP_CLAUSE_COPYOUT)
1059 && gfc_match ("copyout ( ") == MATCH_YES 1099 && gfc_match ("copyout ( ") == MATCH_YES
1060 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1100 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1061 OMP_MAP_FROM)) 1101 OMP_MAP_FROM, true, allow_derived))
1062 continue; 1102 continue;
1063 if ((mask & OMP_CLAUSE_COPYPRIVATE) 1103 if ((mask & OMP_CLAUSE_COPYPRIVATE)
1064 && gfc_match_omp_variable_list ("copyprivate (", 1104 && gfc_match_omp_variable_list ("copyprivate (",
1065 &c->lists[OMP_LIST_COPYPRIVATE], 1105 &c->lists[OMP_LIST_COPYPRIVATE],
1066 true) == MATCH_YES) 1106 true) == MATCH_YES)
1067 continue; 1107 continue;
1068 if ((mask & OMP_CLAUSE_CREATE) 1108 if ((mask & OMP_CLAUSE_CREATE)
1069 && gfc_match ("create ( ") == MATCH_YES 1109 && gfc_match ("create ( ") == MATCH_YES
1070 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1110 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1071 OMP_MAP_ALLOC)) 1111 OMP_MAP_ALLOC, true, allow_derived))
1072 continue; 1112 continue;
1073 break; 1113 break;
1074 case 'd': 1114 case 'd':
1075 if ((mask & OMP_CLAUSE_DEFAULT) 1115 if ((mask & OMP_CLAUSE_DEFAULT)
1076 && c->default_sharing == OMP_DEFAULT_UNKNOWN) 1116 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
1102 continue; 1142 continue;
1103 } 1143 }
1104 if ((mask & OMP_CLAUSE_DELETE) 1144 if ((mask & OMP_CLAUSE_DELETE)
1105 && gfc_match ("delete ( ") == MATCH_YES 1145 && gfc_match ("delete ( ") == MATCH_YES
1106 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1146 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1107 OMP_MAP_RELEASE)) 1147 OMP_MAP_RELEASE, true,
1148 allow_derived))
1108 continue; 1149 continue;
1109 if ((mask & OMP_CLAUSE_DEPEND) 1150 if ((mask & OMP_CLAUSE_DEPEND)
1110 && gfc_match ("depend ( ") == MATCH_YES) 1151 && gfc_match ("depend ( ") == MATCH_YES)
1111 { 1152 {
1112 match m = MATCH_YES; 1153 match m = MATCH_YES;
1145 continue; 1186 continue;
1146 } 1187 }
1147 else 1188 else
1148 gfc_current_locus = old_loc; 1189 gfc_current_locus = old_loc;
1149 } 1190 }
1191 if ((mask & OMP_CLAUSE_DETACH)
1192 && gfc_match ("detach ( ") == MATCH_YES
1193 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1194 OMP_MAP_DETACH, false,
1195 allow_derived))
1196 continue;
1150 if ((mask & OMP_CLAUSE_DEVICE) 1197 if ((mask & OMP_CLAUSE_DEVICE)
1151 && !openacc 1198 && !openacc
1152 && c->device == NULL 1199 && c->device == NULL
1153 && gfc_match ("device ( %e )", &c->device) == MATCH_YES) 1200 && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
1154 continue; 1201 continue;
1155 if ((mask & OMP_CLAUSE_DEVICE) 1202 if ((mask & OMP_CLAUSE_DEVICE)
1156 && openacc 1203 && openacc
1157 && gfc_match ("device ( ") == MATCH_YES 1204 && gfc_match ("device ( ") == MATCH_YES
1158 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1205 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1159 OMP_MAP_FORCE_TO)) 1206 OMP_MAP_FORCE_TO, true,
1207 allow_derived))
1160 continue; 1208 continue;
1161 if ((mask & OMP_CLAUSE_DEVICEPTR) 1209 if ((mask & OMP_CLAUSE_DEVICEPTR)
1162 && gfc_match ("deviceptr ( ") == MATCH_YES 1210 && gfc_match ("deviceptr ( ") == MATCH_YES
1163 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1211 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1164 OMP_MAP_FORCE_DEVICEPTR)) 1212 OMP_MAP_FORCE_DEVICEPTR, false,
1213 allow_derived))
1165 continue; 1214 continue;
1166 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) 1215 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
1167 && gfc_match_omp_variable_list 1216 && gfc_match_omp_variable_list
1168 ("device_resident (", 1217 ("device_resident (",
1169 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES) 1218 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
1237 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES) 1286 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
1238 continue; 1287 continue;
1239 if ((mask & OMP_CLAUSE_HOST_SELF) 1288 if ((mask & OMP_CLAUSE_HOST_SELF)
1240 && gfc_match ("host ( ") == MATCH_YES 1289 && gfc_match ("host ( ") == MATCH_YES
1241 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1290 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1242 OMP_MAP_FORCE_FROM)) 1291 OMP_MAP_FORCE_FROM, true,
1292 allow_derived))
1243 continue; 1293 continue;
1244 break; 1294 break;
1245 case 'i': 1295 case 'i':
1246 if ((mask & OMP_CLAUSE_IF) 1296 if ((mask & OMP_CLAUSE_IF)
1247 && c->if_expr == NULL 1297 && c->if_expr == NULL
1430 c->mergeable = needs_space = true; 1480 c->mergeable = needs_space = true;
1431 continue; 1481 continue;
1432 } 1482 }
1433 break; 1483 break;
1434 case 'n': 1484 case 'n':
1485 if ((mask & OMP_CLAUSE_NO_CREATE)
1486 && gfc_match ("no_create ( ") == MATCH_YES
1487 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1488 OMP_MAP_IF_PRESENT, true,
1489 allow_derived))
1490 continue;
1435 if ((mask & OMP_CLAUSE_NOGROUP) 1491 if ((mask & OMP_CLAUSE_NOGROUP)
1436 && !c->nogroup 1492 && !c->nogroup
1437 && gfc_match ("nogroup") == MATCH_YES) 1493 && gfc_match ("nogroup") == MATCH_YES)
1438 { 1494 {
1439 c->nogroup = needs_space = true; 1495 c->nogroup = needs_space = true;
1509 break; 1565 break;
1510 case 'p': 1566 case 'p':
1511 if ((mask & OMP_CLAUSE_COPY) 1567 if ((mask & OMP_CLAUSE_COPY)
1512 && gfc_match ("pcopy ( ") == MATCH_YES 1568 && gfc_match ("pcopy ( ") == MATCH_YES
1513 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1569 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1514 OMP_MAP_TOFROM)) 1570 OMP_MAP_TOFROM, true, allow_derived))
1515 continue; 1571 continue;
1516 if ((mask & OMP_CLAUSE_COPYIN) 1572 if ((mask & OMP_CLAUSE_COPYIN)
1517 && gfc_match ("pcopyin ( ") == MATCH_YES 1573 && gfc_match ("pcopyin ( ") == MATCH_YES
1518 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1574 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1519 OMP_MAP_TO)) 1575 OMP_MAP_TO, true, allow_derived))
1520 continue; 1576 continue;
1521 if ((mask & OMP_CLAUSE_COPYOUT) 1577 if ((mask & OMP_CLAUSE_COPYOUT)
1522 && gfc_match ("pcopyout ( ") == MATCH_YES 1578 && gfc_match ("pcopyout ( ") == MATCH_YES
1523 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1579 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1524 OMP_MAP_FROM)) 1580 OMP_MAP_FROM, true, allow_derived))
1525 continue; 1581 continue;
1526 if ((mask & OMP_CLAUSE_CREATE) 1582 if ((mask & OMP_CLAUSE_CREATE)
1527 && gfc_match ("pcreate ( ") == MATCH_YES 1583 && gfc_match ("pcreate ( ") == MATCH_YES
1528 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1584 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1529 OMP_MAP_ALLOC)) 1585 OMP_MAP_ALLOC, true, allow_derived))
1530 continue; 1586 continue;
1531 if ((mask & OMP_CLAUSE_PRESENT) 1587 if ((mask & OMP_CLAUSE_PRESENT)
1532 && gfc_match ("present ( ") == MATCH_YES 1588 && gfc_match ("present ( ") == MATCH_YES
1533 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1589 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1534 OMP_MAP_FORCE_PRESENT)) 1590 OMP_MAP_FORCE_PRESENT, false,
1591 allow_derived))
1535 continue; 1592 continue;
1536 if ((mask & OMP_CLAUSE_COPY) 1593 if ((mask & OMP_CLAUSE_COPY)
1537 && gfc_match ("present_or_copy ( ") == MATCH_YES 1594 && gfc_match ("present_or_copy ( ") == MATCH_YES
1538 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1595 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1539 OMP_MAP_TOFROM)) 1596 OMP_MAP_TOFROM, true,
1597 allow_derived))
1540 continue; 1598 continue;
1541 if ((mask & OMP_CLAUSE_COPYIN) 1599 if ((mask & OMP_CLAUSE_COPYIN)
1542 && gfc_match ("present_or_copyin ( ") == MATCH_YES 1600 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1543 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1601 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1544 OMP_MAP_TO)) 1602 OMP_MAP_TO, true, allow_derived))
1545 continue; 1603 continue;
1546 if ((mask & OMP_CLAUSE_COPYOUT) 1604 if ((mask & OMP_CLAUSE_COPYOUT)
1547 && gfc_match ("present_or_copyout ( ") == MATCH_YES 1605 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1548 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1606 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1549 OMP_MAP_FROM)) 1607 OMP_MAP_FROM, true, allow_derived))
1550 continue; 1608 continue;
1551 if ((mask & OMP_CLAUSE_CREATE) 1609 if ((mask & OMP_CLAUSE_CREATE)
1552 && gfc_match ("present_or_create ( ") == MATCH_YES 1610 && gfc_match ("present_or_create ( ") == MATCH_YES
1553 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1611 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1554 OMP_MAP_ALLOC)) 1612 OMP_MAP_ALLOC, true, allow_derived))
1555 continue; 1613 continue;
1556 if ((mask & OMP_CLAUSE_PRIORITY) 1614 if ((mask & OMP_CLAUSE_PRIORITY)
1557 && c->priority == NULL 1615 && c->priority == NULL
1558 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES) 1616 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
1559 continue; 1617 continue;
1667 if (rop == OMP_REDUCTION_NONE && udr) 1725 if (rop == OMP_REDUCTION_NONE && udr)
1668 rop = OMP_REDUCTION_USER; 1726 rop = OMP_REDUCTION_USER;
1669 1727
1670 if (gfc_match_omp_variable_list (" :", 1728 if (gfc_match_omp_variable_list (" :",
1671 &c->lists[OMP_LIST_REDUCTION], 1729 &c->lists[OMP_LIST_REDUCTION],
1672 false, NULL, &head, 1730 false, NULL, &head, openacc,
1673 openacc) == MATCH_YES) 1731 allow_derived) == MATCH_YES)
1674 { 1732 {
1675 gfc_omp_namelist *n; 1733 gfc_omp_namelist *n;
1676 if (rop == OMP_REDUCTION_NONE) 1734 if (rop == OMP_REDUCTION_NONE)
1677 { 1735 {
1678 n = *head; 1736 n = *head;
1708 { 1766 {
1709 int nmodifiers = 0; 1767 int nmodifiers = 0;
1710 locus old_loc2 = gfc_current_locus; 1768 locus old_loc2 = gfc_current_locus;
1711 do 1769 do
1712 { 1770 {
1713 if (!c->sched_simd 1771 if (gfc_match ("simd") == MATCH_YES)
1714 && gfc_match ("simd") == MATCH_YES)
1715 { 1772 {
1716 c->sched_simd = true; 1773 c->sched_simd = true;
1717 nmodifiers++; 1774 nmodifiers++;
1718 } 1775 }
1719 else if (!c->sched_monotonic 1776 else if (gfc_match ("monotonic") == MATCH_YES)
1720 && !c->sched_nonmonotonic
1721 && gfc_match ("monotonic") == MATCH_YES)
1722 { 1777 {
1723 c->sched_monotonic = true; 1778 c->sched_monotonic = true;
1724 nmodifiers++; 1779 nmodifiers++;
1725 } 1780 }
1726 else if (!c->sched_monotonic 1781 else if (gfc_match ("nonmonotonic") == MATCH_YES)
1727 && !c->sched_nonmonotonic
1728 && gfc_match ("nonmonotonic") == MATCH_YES)
1729 { 1782 {
1730 c->sched_nonmonotonic = true; 1783 c->sched_nonmonotonic = true;
1731 nmodifiers++; 1784 nmodifiers++;
1732 } 1785 }
1733 else 1786 else
1734 { 1787 {
1735 if (nmodifiers) 1788 if (nmodifiers)
1736 gfc_current_locus = old_loc2; 1789 gfc_current_locus = old_loc2;
1737 break; 1790 break;
1738 } 1791 }
1739 if (nmodifiers == 0 1792 if (nmodifiers == 1
1740 && gfc_match (" , ") == MATCH_YES) 1793 && gfc_match (" , ") == MATCH_YES)
1741 continue; 1794 continue;
1742 else if (gfc_match (" : ") == MATCH_YES) 1795 else if (gfc_match (" : ") == MATCH_YES)
1743 break; 1796 break;
1744 gfc_current_locus = old_loc2; 1797 gfc_current_locus = old_loc2;
1772 gfc_current_locus = old_loc; 1825 gfc_current_locus = old_loc;
1773 } 1826 }
1774 if ((mask & OMP_CLAUSE_HOST_SELF) 1827 if ((mask & OMP_CLAUSE_HOST_SELF)
1775 && gfc_match ("self ( ") == MATCH_YES 1828 && gfc_match ("self ( ") == MATCH_YES
1776 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], 1829 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1777 OMP_MAP_FORCE_FROM)) 1830 OMP_MAP_FORCE_FROM, true,
1831 allow_derived))
1778 continue; 1832 continue;
1779 if ((mask & OMP_CLAUSE_SEQ) 1833 if ((mask & OMP_CLAUSE_SEQ)
1780 && !c->seq 1834 && !c->seq
1781 && gfc_match ("seq") == MATCH_YES) 1835 && gfc_match ("seq") == MATCH_YES)
1782 { 1836 {
1852 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) 1906 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
1853 && gfc_match_omp_variable_list 1907 && gfc_match_omp_variable_list
1854 ("use_device_ptr (", 1908 ("use_device_ptr (",
1855 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) 1909 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
1856 continue; 1910 continue;
1911 if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
1912 && gfc_match_omp_variable_list
1913 ("use_device_addr (",
1914 &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES)
1915 continue;
1857 break; 1916 break;
1858 case 'v': 1917 case 'v':
1859 /* VECTOR_LENGTH must be matched before VECTOR, because the latter 1918 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1860 doesn't unconditionally match '('. */ 1919 doesn't unconditionally match '('. */
1861 if ((mask & OMP_CLAUSE_VECTOR_LENGTH) 1920 if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
1879 continue; 1938 continue;
1880 } 1939 }
1881 break; 1940 break;
1882 case 'w': 1941 case 'w':
1883 if ((mask & OMP_CLAUSE_WAIT) 1942 if ((mask & OMP_CLAUSE_WAIT)
1884 && !c->wait
1885 && gfc_match ("wait") == MATCH_YES) 1943 && gfc_match ("wait") == MATCH_YES)
1886 { 1944 {
1887 c->wait = true;
1888 match m = match_oacc_expr_list (" (", &c->wait_list, false); 1945 match m = match_oacc_expr_list (" (", &c->wait_list, false);
1889 if (m == MATCH_ERROR) 1946 if (m == MATCH_ERROR)
1890 { 1947 {
1891 gfc_current_locus = old_loc; 1948 gfc_current_locus = old_loc;
1892 break; 1949 break;
1893 } 1950 }
1894 else if (m == MATCH_NO) 1951 else if (m == MATCH_NO)
1895 needs_space = true; 1952 {
1953 gfc_expr *expr
1954 = gfc_get_constant_expr (BT_INTEGER,
1955 gfc_default_integer_kind,
1956 &gfc_current_locus);
1957 mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
1958 gfc_expr_list **expr_list = &c->wait_list;
1959 while (*expr_list)
1960 expr_list = &(*expr_list)->next;
1961 *expr_list = gfc_get_expr_list ();
1962 (*expr_list)->expr = expr;
1963 needs_space = true;
1964 }
1896 continue; 1965 continue;
1897 } 1966 }
1898 if ((mask & OMP_CLAUSE_WORKER) 1967 if ((mask & OMP_CLAUSE_WORKER)
1899 && !c->worker 1968 && !c->worker
1900 && gfc_match ("worker") == MATCH_YES) 1969 && gfc_match ("worker") == MATCH_YES)
1915 break; 1984 break;
1916 } 1985 }
1917 1986
1918 if (gfc_match_omp_eos () != MATCH_YES) 1987 if (gfc_match_omp_eos () != MATCH_YES)
1919 { 1988 {
1989 if (!gfc_error_flag_test ())
1990 gfc_error ("Failed to match clause at %C");
1920 gfc_free_omp_clauses (c); 1991 gfc_free_omp_clauses (c);
1921 return MATCH_ERROR; 1992 return MATCH_ERROR;
1922 } 1993 }
1923 1994
1924 *cp = c; 1995 *cp = c;
1928 1999
1929 #define OACC_PARALLEL_CLAUSES \ 2000 #define OACC_PARALLEL_CLAUSES \
1930 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ 2001 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1931 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ 2002 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1932 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2003 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1933 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEVICEPTR \ 2004 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
1934 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT \ 2005 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1935 | OMP_CLAUSE_WAIT) 2006 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
1936 #define OACC_KERNELS_CLAUSES \ 2007 #define OACC_KERNELS_CLAUSES \
1937 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ 2008 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1938 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ 2009 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
1939 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2010 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1940 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEFAULT \ 2011 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
1941 | OMP_CLAUSE_WAIT) 2012 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
2013 #define OACC_SERIAL_CLAUSES \
2014 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
2015 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
2016 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2017 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2018 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
1942 #define OACC_DATA_CLAUSES \ 2019 #define OACC_DATA_CLAUSES \
1943 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ 2020 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1944 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ 2021 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1945 | OMP_CLAUSE_PRESENT) 2022 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH)
1946 #define OACC_LOOP_CLAUSES \ 2023 #define OACC_LOOP_CLAUSES \
1947 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ 2024 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1948 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ 2025 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1949 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ 2026 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1950 | OMP_CLAUSE_TILE) 2027 | OMP_CLAUSE_TILE)
1951 #define OACC_PARALLEL_LOOP_CLAUSES \ 2028 #define OACC_PARALLEL_LOOP_CLAUSES \
1952 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) 2029 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1953 #define OACC_KERNELS_LOOP_CLAUSES \ 2030 #define OACC_KERNELS_LOOP_CLAUSES \
1954 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) 2031 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1955 #define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE) 2032 #define OACC_SERIAL_LOOP_CLAUSES \
2033 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
2034 #define OACC_HOST_DATA_CLAUSES \
2035 (omp_mask (OMP_CLAUSE_USE_DEVICE) \
2036 | OMP_CLAUSE_IF \
2037 | OMP_CLAUSE_IF_PRESENT)
1956 #define OACC_DECLARE_CLAUSES \ 2038 #define OACC_DECLARE_CLAUSES \
1957 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ 2039 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1958 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ 2040 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1959 | OMP_CLAUSE_PRESENT \ 2041 | OMP_CLAUSE_PRESENT \
1960 | OMP_CLAUSE_LINK) 2042 | OMP_CLAUSE_LINK)
1961 #define OACC_UPDATE_CLAUSES \ 2043 #define OACC_UPDATE_CLAUSES \
1962 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ 2044 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1963 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) 2045 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
1964 #define OACC_ENTER_DATA_CLAUSES \ 2046 #define OACC_ENTER_DATA_CLAUSES \
1965 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ 2047 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1966 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE) 2048 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
1967 #define OACC_EXIT_DATA_CLAUSES \ 2049 #define OACC_EXIT_DATA_CLAUSES \
1968 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ 2050 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1969 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE) 2051 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
2052 | OMP_CLAUSE_DETACH)
1970 #define OACC_WAIT_CLAUSES \ 2053 #define OACC_WAIT_CLAUSES \
1971 omp_mask (OMP_CLAUSE_ASYNC) 2054 omp_mask (OMP_CLAUSE_ASYNC)
1972 #define OACC_ROUTINE_CLAUSES \ 2055 #define OACC_ROUTINE_CLAUSES \
1973 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ 2056 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
1974 | OMP_CLAUSE_SEQ) 2057 | OMP_CLAUSE_SEQ)
2012 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); 2095 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
2013 } 2096 }
2014 2097
2015 2098
2016 match 2099 match
2100 gfc_match_oacc_serial_loop (void)
2101 {
2102 return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
2103 }
2104
2105
2106 match
2107 gfc_match_oacc_serial (void)
2108 {
2109 return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
2110 }
2111
2112
2113 match
2017 gfc_match_oacc_data (void) 2114 gfc_match_oacc_data (void)
2018 { 2115 {
2019 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); 2116 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
2020 } 2117 }
2021 2118
2066 &where); 2163 &where);
2067 return MATCH_ERROR; 2164 return MATCH_ERROR;
2068 } 2165 }
2069 2166
2070 module_var = true; 2167 module_var = true;
2071 }
2072
2073 if (ns->proc_name->attr.oacc_function)
2074 {
2075 gfc_error ("Invalid declare in routine with $!ACC DECLARE at %L",
2076 &where);
2077 return MATCH_ERROR;
2078 } 2168 }
2079 2169
2080 if (s->attr.use_assoc) 2170 if (s->attr.use_assoc)
2081 { 2171 {
2082 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L", 2172 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
2232 new_st.op = EXEC_OACC_CACHE; 2322 new_st.op = EXEC_OACC_CACHE;
2233 new_st.ext.omp_clauses = c; 2323 new_st.ext.omp_clauses = c;
2234 return MATCH_YES; 2324 return MATCH_YES;
2235 } 2325 }
2236 2326
2237 /* Determine the loop level for a routine. */ 2327 /* Determine the OpenACC 'routine' directive's level of parallelism. */
2238 2328
2239 static int 2329 static oacc_routine_lop
2240 gfc_oacc_routine_dims (gfc_omp_clauses *clauses) 2330 gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
2241 { 2331 {
2242 int level = -1; 2332 oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
2243 2333
2244 if (clauses) 2334 if (clauses)
2245 { 2335 {
2246 unsigned mask = 0; 2336 unsigned n_lop_clauses = 0;
2247 2337
2248 if (clauses->gang) 2338 if (clauses->gang)
2249 level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level); 2339 {
2340 ++n_lop_clauses;
2341 ret = OACC_ROUTINE_LOP_GANG;
2342 }
2250 if (clauses->worker) 2343 if (clauses->worker)
2251 level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level); 2344 {
2345 ++n_lop_clauses;
2346 ret = OACC_ROUTINE_LOP_WORKER;
2347 }
2252 if (clauses->vector) 2348 if (clauses->vector)
2253 level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level); 2349 {
2350 ++n_lop_clauses;
2351 ret = OACC_ROUTINE_LOP_VECTOR;
2352 }
2254 if (clauses->seq) 2353 if (clauses->seq)
2255 level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level); 2354 {
2256 2355 ++n_lop_clauses;
2257 if (mask != (mask & -mask)) 2356 ret = OACC_ROUTINE_LOP_SEQ;
2258 gfc_error ("Multiple loop axes specified for routine"); 2357 }
2259 } 2358
2260 2359 if (n_lop_clauses > 1)
2261 if (level < 0) 2360 ret = OACC_ROUTINE_LOP_ERROR;
2262 level = GOMP_DIM_MAX; 2361 }
2263 2362
2264 return level; 2363 return ret;
2265 } 2364 }
2266 2365
2267 match 2366 match
2268 gfc_match_oacc_routine (void) 2367 gfc_match_oacc_routine (void)
2269 { 2368 {
2270 locus old_loc; 2369 locus old_loc;
2370 match m;
2371 gfc_intrinsic_sym *isym = NULL;
2271 gfc_symbol *sym = NULL; 2372 gfc_symbol *sym = NULL;
2272 match m;
2273 gfc_omp_clauses *c = NULL; 2373 gfc_omp_clauses *c = NULL;
2274 gfc_oacc_routine_name *n = NULL; 2374 gfc_oacc_routine_name *n = NULL;
2375 oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
2275 2376
2276 old_loc = gfc_current_locus; 2377 old_loc = gfc_current_locus;
2277 2378
2278 m = gfc_match (" ("); 2379 m = gfc_match (" (");
2279 2380
2287 } 2388 }
2288 2389
2289 if (m == MATCH_YES) 2390 if (m == MATCH_YES)
2290 { 2391 {
2291 char buffer[GFC_MAX_SYMBOL_LEN + 1]; 2392 char buffer[GFC_MAX_SYMBOL_LEN + 1];
2292 gfc_symtree *st;
2293 2393
2294 m = gfc_match_name (buffer); 2394 m = gfc_match_name (buffer);
2295 if (m == MATCH_YES) 2395 if (m == MATCH_YES)
2296 { 2396 {
2297 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); 2397 gfc_symtree *st = NULL;
2398
2399 /* First look for an intrinsic symbol. */
2400 isym = gfc_find_function (buffer);
2401 if (!isym)
2402 isym = gfc_find_subroutine (buffer);
2403 /* If no intrinsic symbol found, search the current namespace. */
2404 if (!isym)
2405 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
2298 if (st) 2406 if (st)
2299 { 2407 {
2300 sym = st->n.sym; 2408 sym = st->n.sym;
2409 /* If the name in a 'routine' directive refers to the containing
2410 subroutine or function, then make sure that we'll later handle
2411 this accordingly. */
2301 if (gfc_current_ns->proc_name != NULL 2412 if (gfc_current_ns->proc_name != NULL
2302 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) 2413 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
2303 sym = NULL; 2414 sym = NULL;
2304 } 2415 }
2305 2416
2306 if (st == NULL 2417 if (isym == NULL && st == NULL)
2307 || (sym 2418 {
2308 && !sym->attr.external 2419 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
2309 && !sym->attr.function 2420 buffer);
2310 && !sym->attr.subroutine))
2311 {
2312 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
2313 "invalid function name %s",
2314 (sym) ? sym->name : buffer);
2315 gfc_current_locus = old_loc; 2421 gfc_current_locus = old_loc;
2316 return MATCH_ERROR; 2422 return MATCH_ERROR;
2317 } 2423 }
2318 } 2424 }
2319 else 2425 else
2335 if (gfc_match_omp_eos () != MATCH_YES 2441 if (gfc_match_omp_eos () != MATCH_YES
2336 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) 2442 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
2337 != MATCH_YES)) 2443 != MATCH_YES))
2338 return MATCH_ERROR; 2444 return MATCH_ERROR;
2339 2445
2340 if (sym != NULL) 2446 lop = gfc_oacc_routine_lop (c);
2341 { 2447 if (lop == OACC_ROUTINE_LOP_ERROR)
2342 n = gfc_get_oacc_routine_name (); 2448 {
2343 n->sym = sym; 2449 gfc_error ("Multiple loop axes specified for routine at %C");
2344 n->clauses = NULL; 2450 goto cleanup;
2345 n->next = NULL; 2451 }
2346 if (gfc_current_ns->oacc_routine_names != NULL) 2452
2347 n->next = gfc_current_ns->oacc_routine_names; 2453 if (isym != NULL)
2348 2454 {
2349 gfc_current_ns->oacc_routine_names = n; 2455 /* Diagnose any OpenACC 'routine' directive that doesn't match the
2456 (implicit) one with a 'seq' clause. */
2457 if (c && (c->gang || c->worker || c->vector))
2458 {
2459 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
2460 " at %C marked with incompatible GANG, WORKER, or VECTOR"
2461 " clause");
2462 goto cleanup;
2463 }
2464 }
2465 else if (sym != NULL)
2466 {
2467 bool add = true;
2468
2469 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
2470 match the first one. */
2471 for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
2472 n_p;
2473 n_p = n_p->next)
2474 if (n_p->sym == sym)
2475 {
2476 add = false;
2477 if (lop != gfc_oacc_routine_lop (n_p->clauses))
2478 {
2479 gfc_error ("!$ACC ROUTINE already applied at %C");
2480 goto cleanup;
2481 }
2482 }
2483
2484 if (add)
2485 {
2486 sym->attr.oacc_routine_lop = lop;
2487
2488 n = gfc_get_oacc_routine_name ();
2489 n->sym = sym;
2490 n->clauses = c;
2491 n->next = gfc_current_ns->oacc_routine_names;
2492 n->loc = old_loc;
2493 gfc_current_ns->oacc_routine_names = n;
2494 }
2350 } 2495 }
2351 else if (gfc_current_ns->proc_name) 2496 else if (gfc_current_ns->proc_name)
2352 { 2497 {
2498 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
2499 match the first one. */
2500 oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
2501 if (lop_p != OACC_ROUTINE_LOP_NONE
2502 && lop != lop_p)
2503 {
2504 gfc_error ("!$ACC ROUTINE already applied at %C");
2505 goto cleanup;
2506 }
2507
2353 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, 2508 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
2354 gfc_current_ns->proc_name->name, 2509 gfc_current_ns->proc_name->name,
2355 &old_loc)) 2510 &old_loc))
2356 goto cleanup; 2511 goto cleanup;
2357 gfc_current_ns->proc_name->attr.oacc_function 2512 gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
2358 = gfc_oacc_routine_dims (c) + 1; 2513 }
2359 } 2514 else
2515 /* Something has gone wrong, possibly a syntax error. */
2516 goto cleanup;
2360 2517
2361 if (n) 2518 if (n)
2362 n->clauses = c; 2519 n->clauses = c;
2363 else if (gfc_current_ns->oacc_routine) 2520 else if (gfc_current_ns->oacc_routine)
2364 gfc_current_ns->oacc_routine_clauses = c; 2521 gfc_current_ns->oacc_routine_clauses = c;
2400 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ 2557 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
2401 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY) 2558 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
2402 #define OMP_TASKLOOP_CLAUSES \ 2559 #define OMP_TASKLOOP_CLAUSES \
2403 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2560 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2404 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ 2561 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
2405 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ 2562 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
2406 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ 2563 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
2407 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP) 2564 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
2408 #define OMP_TARGET_CLAUSES \ 2565 #define OMP_TARGET_CLAUSES \
2409 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2566 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2410 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ 2567 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
2411 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ 2568 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
2412 | OMP_CLAUSE_IS_DEVICE_PTR) 2569 | OMP_CLAUSE_IS_DEVICE_PTR)
2413 #define OMP_TARGET_DATA_CLAUSES \ 2570 #define OMP_TARGET_DATA_CLAUSES \
2414 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2571 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2415 | OMP_CLAUSE_USE_DEVICE_PTR) 2572 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
2416 #define OMP_TARGET_ENTER_DATA_CLAUSES \ 2573 #define OMP_TARGET_ENTER_DATA_CLAUSES \
2417 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2574 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2418 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) 2575 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2419 #define OMP_TARGET_EXIT_DATA_CLAUSES \ 2576 #define OMP_TARGET_EXIT_DATA_CLAUSES \
2420 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ 2577 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2422 #define OMP_TARGET_UPDATE_CLAUSES \ 2579 #define OMP_TARGET_UPDATE_CLAUSES \
2423 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ 2580 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
2424 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) 2581 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2425 #define OMP_TEAMS_CLAUSES \ 2582 #define OMP_TEAMS_CLAUSES \
2426 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ 2583 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
2427 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ 2584 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2428 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION) 2585 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
2429 #define OMP_DISTRIBUTE_CLAUSES \ 2586 #define OMP_DISTRIBUTE_CLAUSES \
2430 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ 2587 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2431 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE) 2588 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
2432 #define OMP_SINGLE_CLAUSES \ 2589 #define OMP_SINGLE_CLAUSES \
3696 static bool 3853 static bool
3697 oacc_is_loop (gfc_code *code) 3854 oacc_is_loop (gfc_code *code)
3698 { 3855 {
3699 return code->op == EXEC_OACC_PARALLEL_LOOP 3856 return code->op == EXEC_OACC_PARALLEL_LOOP
3700 || code->op == EXEC_OACC_KERNELS_LOOP 3857 || code->op == EXEC_OACC_KERNELS_LOOP
3858 || code->op == EXEC_OACC_SERIAL_LOOP
3701 || code->op == EXEC_OACC_LOOP; 3859 || code->op == EXEC_OACC_LOOP;
3702 } 3860 }
3703 3861
3704 static void 3862 static void
3705 resolve_scalar_int_expr (gfc_expr *expr, const char *clause) 3863 resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
3737 of derived of polymorphic type. */ 3895 of derived of polymorphic type. */
3738 3896
3739 static void 3897 static void
3740 check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) 3898 check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
3741 { 3899 {
3742 if (sym->ts.type == BT_DERIVED && sym->attr.pointer)
3743 gfc_error ("POINTER object %qs of derived type in %s clause at %L",
3744 sym->name, name, &loc);
3745 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) 3900 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
3746 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", 3901 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
3747 sym->name, name, &loc); 3902 sym->name, name, &loc);
3748 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) 3903 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
3749 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L", 3904 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
3775 gfc_error ("Assumed size array %qs in %s clause at %L", 3930 gfc_error ("Assumed size array %qs in %s clause at %L",
3776 sym->name, name, &loc); 3931 sym->name, name, &loc);
3777 if (sym->as && sym->as->type == AS_ASSUMED_RANK) 3932 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
3778 gfc_error ("Assumed rank array %qs in %s clause at %L", 3933 gfc_error ("Assumed rank array %qs in %s clause at %L",
3779 sym->name, name, &loc); 3934 sym->name, name, &loc);
3780 if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer
3781 && !sym->attr.contiguous)
3782 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3783 sym->name, name, &loc);
3784 } 3935 }
3785 3936
3786 static void 3937 static void
3787 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) 3938 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
3788 { 3939 {
3789 if (sym->ts.type == BT_DERIVED && sym->attr.allocatable)
3790 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3791 sym->name, name, &loc);
3792 if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
3793 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3794 && CLASS_DATA (sym)->attr.allocatable))
3795 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3796 "in %s clause at %L", sym->name, name, &loc);
3797 check_symbol_not_pointer (sym, loc, name);
3798 check_array_not_assumed (sym, loc, name); 3940 check_array_not_assumed (sym, loc, name);
3799 } 3941 }
3800 3942
3801 static void 3943 static void
3802 resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) 3944 resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
3939 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; 4081 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3940 static const char *clause_names[] 4082 static const char *clause_names[]
3941 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", 4083 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3942 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", 4084 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3943 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", 4085 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3944 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" }; 4086 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR" };
3945 4087
3946 if (omp_clauses == NULL) 4088 if (omp_clauses == NULL)
3947 return; 4089 return;
3948 4090
3949 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) 4091 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
4073 && expr->ts.type == BT_INTEGER 4215 && expr->ts.type == BT_INTEGER
4074 && mpz_sgn (expr->value.integer) <= 0) 4216 && mpz_sgn (expr->value.integer) <= 0)
4075 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " 4217 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
4076 "at %L must be positive", &expr->where); 4218 "at %L must be positive", &expr->where);
4077 } 4219 }
4220 if (omp_clauses->sched_kind != OMP_SCHED_NONE
4221 && omp_clauses->sched_nonmonotonic)
4222 {
4223 if (omp_clauses->sched_kind != OMP_SCHED_DYNAMIC
4224 && omp_clauses->sched_kind != OMP_SCHED_GUIDED)
4225 {
4226 const char *p;
4227 switch (omp_clauses->sched_kind)
4228 {
4229 case OMP_SCHED_STATIC: p = "STATIC"; break;
4230 case OMP_SCHED_RUNTIME: p = "RUNTIME"; break;
4231 case OMP_SCHED_AUTO: p = "AUTO"; break;
4232 default: gcc_unreachable ();
4233 }
4234 gfc_error ("NONMONOTONIC modifier specified for %s schedule kind "
4235 "at %L", p, &code->loc);
4236 }
4237 else if (omp_clauses->sched_monotonic)
4238 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
4239 "specified at %L", &code->loc);
4240 else if (omp_clauses->ordered)
4241 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
4242 "clause at %L", &code->loc);
4243 }
4078 4244
4079 /* Check that no symbol appears on multiple clauses, except that 4245 /* Check that no symbol appears on multiple clauses, except that
4080 a symbol can appear on both firstprivate and lastprivate. */ 4246 a symbol can appear on both firstprivate and lastprivate. */
4081 for (list = 0; list < OMP_LIST_NUM; list++) 4247 for (list = 0; list < OMP_LIST_NUM; list++)
4082 for (n = omp_clauses->lists[list]; n; n = n->next) 4248 for (n = omp_clauses->lists[list]; n; n = n->next)
4083 { 4249 {
4084 n->sym->mark = 0; 4250 n->sym->mark = 0;
4251 n->sym->comp_mark = 0;
4085 if (n->sym->attr.flavor == FL_VARIABLE 4252 if (n->sym->attr.flavor == FL_VARIABLE
4086 || n->sym->attr.proc_pointer 4253 || n->sym->attr.proc_pointer
4087 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) 4254 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
4088 { 4255 {
4089 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) 4256 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
4117 break; 4284 break;
4118 if (el) 4285 if (el)
4119 continue; 4286 continue;
4120 } 4287 }
4121 } 4288 }
4122 gfc_error ("Object %qs is not a variable at %L", n->sym->name, 4289 if (list == OMP_LIST_MAP
4123 &n->where); 4290 && n->sym->attr.flavor == FL_PARAMETER)
4291 {
4292 if (openacc)
4293 gfc_error ("Object %qs is not a variable at %L; parameters"
4294 " cannot be and need not be copied", n->sym->name,
4295 &n->where);
4296 else
4297 gfc_error ("Object %qs is not a variable at %L; parameters"
4298 " cannot be and need not be mapped", n->sym->name,
4299 &n->where);
4300 }
4301 else
4302 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
4303 &n->where);
4124 } 4304 }
4125 4305
4126 for (list = 0; list < OMP_LIST_NUM; list++) 4306 for (list = 0; list < OMP_LIST_NUM; list++)
4127 if (list != OMP_LIST_FIRSTPRIVATE 4307 if (list != OMP_LIST_FIRSTPRIVATE
4128 && list != OMP_LIST_LASTPRIVATE 4308 && list != OMP_LIST_LASTPRIVATE
4132 && list != OMP_LIST_FROM 4312 && list != OMP_LIST_FROM
4133 && list != OMP_LIST_TO 4313 && list != OMP_LIST_TO
4134 && (list != OMP_LIST_REDUCTION || !openacc)) 4314 && (list != OMP_LIST_REDUCTION || !openacc))
4135 for (n = omp_clauses->lists[list]; n; n = n->next) 4315 for (n = omp_clauses->lists[list]; n; n = n->next)
4136 { 4316 {
4137 if (n->sym->mark) 4317 bool component_ref_p = false;
4318
4319 /* Allow multiple components of the same (e.g. derived-type)
4320 variable here. Duplicate components are detected elsewhere. */
4321 if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
4322 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4323 if (ref->type == REF_COMPONENT)
4324 component_ref_p = true;
4325 if ((!component_ref_p && n->sym->comp_mark)
4326 || (component_ref_p && n->sym->mark))
4327 gfc_error ("Symbol %qs has mixed component and non-component "
4328 "accesses at %L", n->sym->name, &n->where);
4329 else if (n->sym->mark)
4138 gfc_error ("Symbol %qs present on multiple clauses at %L", 4330 gfc_error ("Symbol %qs present on multiple clauses at %L",
4139 n->sym->name, &n->where); 4331 n->sym->name, &n->where);
4140 else 4332 else
4141 n->sym->mark = 1; 4333 {
4334 if (component_ref_p)
4335 n->sym->comp_mark = 1;
4336 else
4337 n->sym->mark = 1;
4338 }
4142 } 4339 }
4143 4340
4144 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); 4341 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
4145 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) 4342 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
4146 for (n = omp_clauses->lists[list]; n; n = n->next) 4343 for (n = omp_clauses->lists[list]; n; n = n->next)
4327 else if (code->op == EXEC_OMP_ORDERED) 4524 else if (code->op == EXEC_OMP_ORDERED)
4328 gfc_error ("Only SOURCE or SINK dependence types " 4525 gfc_error ("Only SOURCE or SINK dependence types "
4329 "are allowed on ORDERED directive at %L", 4526 "are allowed on ORDERED directive at %L",
4330 &n->where); 4527 &n->where);
4331 } 4528 }
4529 gfc_ref *array_ref = NULL;
4530 bool resolved = false;
4332 if (n->expr) 4531 if (n->expr)
4333 { 4532 {
4334 if (!gfc_resolve_expr (n->expr) 4533 array_ref = n->expr->ref;
4534 resolved = gfc_resolve_expr (n->expr);
4535
4536 /* Look through component refs to find last array
4537 reference. */
4538 if (openacc && resolved)
4539 {
4540 /* The "!$acc cache" directive allows rectangular
4541 subarrays to be specified, with some restrictions
4542 on the form of bounds (not implemented).
4543 Only raise an error here if we're really sure the
4544 array isn't contiguous. An expression such as
4545 arr(-n:n,-n:n) could be contiguous even if it looks
4546 like it may not be. */
4547 if (list != OMP_LIST_CACHE
4548 && !gfc_is_simply_contiguous (n->expr, false, true)
4549 && gfc_is_not_contiguous (n->expr))
4550 gfc_error ("Array is not contiguous at %L",
4551 &n->where);
4552
4553 while (array_ref
4554 && (array_ref->type == REF_COMPONENT
4555 || (array_ref->type == REF_ARRAY
4556 && array_ref->next
4557 && (array_ref->next->type
4558 == REF_COMPONENT))))
4559 array_ref = array_ref->next;
4560 }
4561 }
4562 if (array_ref
4563 || (n->expr
4564 && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
4565 {
4566 if (!resolved
4335 || n->expr->expr_type != EXPR_VARIABLE 4567 || n->expr->expr_type != EXPR_VARIABLE
4336 || n->expr->ref == NULL 4568 || array_ref->next
4337 || n->expr->ref->next 4569 || array_ref->type != REF_ARRAY)
4338 || n->expr->ref->type != REF_ARRAY)
4339 gfc_error ("%qs in %s clause at %L is not a proper " 4570 gfc_error ("%qs in %s clause at %L is not a proper "
4340 "array section", n->sym->name, name, 4571 "array section", n->sym->name, name,
4341 &n->where); 4572 &n->where);
4342 else if (n->expr->ref->u.ar.codimen)
4343 gfc_error ("Coarrays not supported in %s clause at %L",
4344 name, &n->where);
4345 else 4573 else
4346 { 4574 {
4347 int i; 4575 int i;
4348 gfc_array_ref *ar = &n->expr->ref->u.ar; 4576 gfc_array_ref *ar = &array_ref->u.ar;
4349 for (i = 0; i < ar->dimen; i++) 4577 for (i = 0; i < ar->dimen; i++)
4350 if (ar->stride[i]) 4578 if (ar->stride[i])
4351 { 4579 {
4352 gfc_error ("Stride should not be specified for " 4580 gfc_error ("Stride should not be specified for "
4353 "array section in %s clause at %L", 4581 "array section in %s clause at %L",
4459 gfc_error ("Cray pointee %qs in %s clause at %L", 4687 gfc_error ("Cray pointee %qs in %s clause at %L",
4460 n->sym->name, name, &n->where); 4688 n->sym->name, name, &n->where);
4461 } 4689 }
4462 break; 4690 break;
4463 case OMP_LIST_IS_DEVICE_PTR: 4691 case OMP_LIST_IS_DEVICE_PTR:
4692 if (!n->sym->attr.dummy)
4693 gfc_error ("Non-dummy object %qs in %s clause at %L",
4694 n->sym->name, name, &n->where);
4695 if (n->sym->attr.allocatable
4696 || (n->sym->ts.type == BT_CLASS
4697 && CLASS_DATA (n->sym)->attr.allocatable))
4698 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4699 n->sym->name, name, &n->where);
4700 if (n->sym->attr.pointer
4701 || (n->sym->ts.type == BT_CLASS
4702 && CLASS_DATA (n->sym)->attr.pointer))
4703 gfc_error ("POINTER object %qs in %s clause at %L",
4704 n->sym->name, name, &n->where);
4705 if (n->sym->attr.value)
4706 gfc_error ("VALUE object %qs in %s clause at %L",
4707 n->sym->name, name, &n->where);
4708 break;
4464 case OMP_LIST_USE_DEVICE_PTR: 4709 case OMP_LIST_USE_DEVICE_PTR:
4465 /* FIXME: Handle these. */ 4710 case OMP_LIST_USE_DEVICE_ADDR:
4711 /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
4466 break; 4712 break;
4467 default: 4713 default:
4468 for (; n != NULL; n = n->next) 4714 for (; n != NULL; n = n->next)
4469 { 4715 {
4470 bool bad = false; 4716 bool bad = false;
4488 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION) 4734 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
4489 gfc_error ("Cray pointer %qs in %s clause at %L", 4735 gfc_error ("Cray pointer %qs in %s clause at %L",
4490 n->sym->name, name, &n->where); 4736 n->sym->name, name, &n->where);
4491 } 4737 }
4492 if (code 4738 if (code
4493 && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL)) 4739 && (oacc_is_loop (code)
4740 || code->op == EXEC_OACC_PARALLEL
4741 || code->op == EXEC_OACC_SERIAL))
4494 check_array_not_assumed (n->sym, n->where, name); 4742 check_array_not_assumed (n->sym, n->where, name);
4495 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) 4743 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4496 gfc_error ("Assumed size array %qs in %s clause at %L", 4744 gfc_error ("Assumed size array %qs in %s clause at %L",
4497 n->sym->name, name, &n->where); 4745 n->sym->name, name, &n->where);
4498 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION) 4746 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
4759 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG"); 5007 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
4760 if (omp_clauses->worker_expr) 5008 if (omp_clauses->worker_expr)
4761 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); 5009 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
4762 if (omp_clauses->vector_expr) 5010 if (omp_clauses->vector_expr)
4763 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR"); 5011 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
4764 if (omp_clauses->wait) 5012 for (el = omp_clauses->wait_list; el; el = el->next)
4765 if (omp_clauses->wait_list) 5013 resolve_scalar_int_expr (el->expr, "WAIT");
4766 for (el = omp_clauses->wait_list; el; el = el->next)
4767 resolve_scalar_int_expr (el->expr, "WAIT");
4768 if (omp_clauses->collapse && omp_clauses->tile_list) 5014 if (omp_clauses->collapse && omp_clauses->tile_list)
4769 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); 5015 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
4770 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) 5016 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
4771 gfc_error ("SOURCE dependence type only allowed " 5017 gfc_error ("SOURCE dependence type only allowed "
4772 "on ORDERED directive at %L", &code->loc); 5018 "on ORDERED directive at %L", &code->loc);
5421 5667
5422 /* An openacc context may represent a data clause. Abort if so. */ 5668 /* An openacc context may represent a data clause. Abort if so. */
5423 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) 5669 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
5424 return; 5670 return;
5425 5671
5426 if (omp_current_ctx->is_openmp 5672 if (omp_current_ctx->sharing_clauses->contains (sym))
5427 && omp_current_ctx->sharing_clauses->contains (sym))
5428 return; 5673 return;
5429 5674
5430 if (! omp_current_ctx->private_iterators->add (sym) && add_clause) 5675 if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
5431 { 5676 {
5432 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; 5677 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
5642 oacc_is_parallel (gfc_code *code) 5887 oacc_is_parallel (gfc_code *code)
5643 { 5888 {
5644 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP; 5889 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
5645 } 5890 }
5646 5891
5647 static bool
5648 oacc_is_kernels (gfc_code *code)
5649 {
5650 return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
5651 }
5652
5653 static gfc_statement 5892 static gfc_statement
5654 omp_code_to_statement (gfc_code *code) 5893 omp_code_to_statement (gfc_code *code)
5655 { 5894 {
5656 switch (code->op) 5895 switch (code->op)
5657 { 5896 {
5675 return ST_OMP_WORKSHARE; 5914 return ST_OMP_WORKSHARE;
5676 case EXEC_OMP_PARALLEL_WORKSHARE: 5915 case EXEC_OMP_PARALLEL_WORKSHARE:
5677 return ST_OMP_PARALLEL_WORKSHARE; 5916 return ST_OMP_PARALLEL_WORKSHARE;
5678 case EXEC_OMP_DO: 5917 case EXEC_OMP_DO:
5679 return ST_OMP_DO; 5918 return ST_OMP_DO;
5919 case EXEC_OMP_ATOMIC:
5920 return ST_OMP_ATOMIC;
5921 case EXEC_OMP_BARRIER:
5922 return ST_OMP_BARRIER;
5923 case EXEC_OMP_CANCEL:
5924 return ST_OMP_CANCEL;
5925 case EXEC_OMP_CANCELLATION_POINT:
5926 return ST_OMP_CANCELLATION_POINT;
5927 case EXEC_OMP_FLUSH:
5928 return ST_OMP_FLUSH;
5929 case EXEC_OMP_DISTRIBUTE:
5930 return ST_OMP_DISTRIBUTE;
5931 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5932 return ST_OMP_DISTRIBUTE_PARALLEL_DO;
5933 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5934 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
5935 case EXEC_OMP_DISTRIBUTE_SIMD:
5936 return ST_OMP_DISTRIBUTE_SIMD;
5937 case EXEC_OMP_DO_SIMD:
5938 return ST_OMP_DO_SIMD;
5939 case EXEC_OMP_SIMD:
5940 return ST_OMP_SIMD;
5941 case EXEC_OMP_TARGET:
5942 return ST_OMP_TARGET;
5943 case EXEC_OMP_TARGET_DATA:
5944 return ST_OMP_TARGET_DATA;
5945 case EXEC_OMP_TARGET_ENTER_DATA:
5946 return ST_OMP_TARGET_ENTER_DATA;
5947 case EXEC_OMP_TARGET_EXIT_DATA:
5948 return ST_OMP_TARGET_EXIT_DATA;
5949 case EXEC_OMP_TARGET_PARALLEL:
5950 return ST_OMP_TARGET_PARALLEL;
5951 case EXEC_OMP_TARGET_PARALLEL_DO:
5952 return ST_OMP_TARGET_PARALLEL_DO;
5953 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5954 return ST_OMP_TARGET_PARALLEL_DO_SIMD;
5955 case EXEC_OMP_TARGET_SIMD:
5956 return ST_OMP_TARGET_SIMD;
5957 case EXEC_OMP_TARGET_TEAMS:
5958 return ST_OMP_TARGET_TEAMS;
5959 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5960 return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
5961 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5962 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5963 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5964 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5965 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5966 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
5967 case EXEC_OMP_TARGET_UPDATE:
5968 return ST_OMP_TARGET_UPDATE;
5969 case EXEC_OMP_TASKGROUP:
5970 return ST_OMP_TASKGROUP;
5971 case EXEC_OMP_TASKLOOP:
5972 return ST_OMP_TASKLOOP;
5973 case EXEC_OMP_TASKLOOP_SIMD:
5974 return ST_OMP_TASKLOOP_SIMD;
5975 case EXEC_OMP_TASKWAIT:
5976 return ST_OMP_TASKWAIT;
5977 case EXEC_OMP_TASKYIELD:
5978 return ST_OMP_TASKYIELD;
5979 case EXEC_OMP_TEAMS:
5980 return ST_OMP_TEAMS;
5981 case EXEC_OMP_TEAMS_DISTRIBUTE:
5982 return ST_OMP_TEAMS_DISTRIBUTE;
5983 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5984 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
5985 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5986 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5987 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5988 return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
5989 case EXEC_OMP_PARALLEL_DO:
5990 return ST_OMP_PARALLEL_DO;
5991 case EXEC_OMP_PARALLEL_DO_SIMD:
5992 return ST_OMP_PARALLEL_DO_SIMD;
5993
5680 default: 5994 default:
5681 gcc_unreachable (); 5995 gcc_unreachable ();
5682 } 5996 }
5683 } 5997 }
5684 5998
5689 { 6003 {
5690 case EXEC_OACC_PARALLEL: 6004 case EXEC_OACC_PARALLEL:
5691 return ST_OACC_PARALLEL; 6005 return ST_OACC_PARALLEL;
5692 case EXEC_OACC_KERNELS: 6006 case EXEC_OACC_KERNELS:
5693 return ST_OACC_KERNELS; 6007 return ST_OACC_KERNELS;
6008 case EXEC_OACC_SERIAL:
6009 return ST_OACC_SERIAL;
5694 case EXEC_OACC_DATA: 6010 case EXEC_OACC_DATA:
5695 return ST_OACC_DATA; 6011 return ST_OACC_DATA;
5696 case EXEC_OACC_HOST_DATA: 6012 case EXEC_OACC_HOST_DATA:
5697 return ST_OACC_HOST_DATA; 6013 return ST_OACC_HOST_DATA;
5698 case EXEC_OACC_PARALLEL_LOOP: 6014 case EXEC_OACC_PARALLEL_LOOP:
5699 return ST_OACC_PARALLEL_LOOP; 6015 return ST_OACC_PARALLEL_LOOP;
5700 case EXEC_OACC_KERNELS_LOOP: 6016 case EXEC_OACC_KERNELS_LOOP:
5701 return ST_OACC_KERNELS_LOOP; 6017 return ST_OACC_KERNELS_LOOP;
6018 case EXEC_OACC_SERIAL_LOOP:
6019 return ST_OACC_SERIAL_LOOP;
5702 case EXEC_OACC_LOOP: 6020 case EXEC_OACC_LOOP:
5703 return ST_OACC_LOOP; 6021 return ST_OACC_LOOP;
5704 case EXEC_OACC_ATOMIC: 6022 case EXEC_OACC_ATOMIC:
5705 return ST_OACC_ATOMIC; 6023 return ST_OACC_ATOMIC;
6024 case EXEC_OACC_ROUTINE:
6025 return ST_OACC_ROUTINE;
6026 case EXEC_OACC_UPDATE:
6027 return ST_OACC_UPDATE;
6028 case EXEC_OACC_WAIT:
6029 return ST_OACC_WAIT;
6030 case EXEC_OACC_CACHE:
6031 return ST_OACC_CACHE;
6032 case EXEC_OACC_ENTER_DATA:
6033 return ST_OACC_ENTER_DATA;
6034 case EXEC_OACC_EXIT_DATA:
6035 return ST_OACC_EXIT_DATA;
6036 case EXEC_OACC_DECLARE:
6037 return ST_OACC_DECLARE;
5706 default: 6038 default:
5707 gcc_unreachable (); 6039 gcc_unreachable ();
5708 } 6040 }
5709 } 6041 }
5710 6042
5749 { 6081 {
5750 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " 6082 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5751 "at %L", &do_code->loc); 6083 "at %L", &do_code->loc);
5752 break; 6084 break;
5753 } 6085 }
5754 gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT); 6086 if (do_code->op == EXEC_DO_CONCURRENT)
6087 {
6088 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
6089 &do_code->loc);
6090 break;
6091 }
6092 gcc_assert (do_code->op == EXEC_DO);
5755 if (do_code->ext.iterator->var->ts.type != BT_INTEGER) 6093 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5756 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L", 6094 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5757 &do_code->loc); 6095 &do_code->loc);
5758 dovar = do_code->ext.iterator->var->symtree->n.sym; 6096 dovar = do_code->ext.iterator->var->symtree->n.sym;
5759 if (i > 1) 6097 if (i > 1)
5829 6167
5830 6168
5831 static void 6169 static void
5832 resolve_oacc_loop_blocks (gfc_code *code) 6170 resolve_oacc_loop_blocks (gfc_code *code)
5833 { 6171 {
5834 fortran_omp_context *c;
5835
5836 if (!oacc_is_loop (code)) 6172 if (!oacc_is_loop (code))
5837 return; 6173 return;
5838 6174
5839 if (code->op == EXEC_OACC_LOOP)
5840 for (c = omp_current_ctx; c; c = c->previous)
5841 {
5842 if (oacc_is_loop (c->code))
5843 {
5844 if (code->ext.omp_clauses->gang)
5845 {
5846 if (c->code->ext.omp_clauses->gang)
5847 gfc_error ("Loop parallelized across gangs is not allowed "
5848 "inside another loop parallelized across gangs at %L",
5849 &code->loc);
5850 if (c->code->ext.omp_clauses->worker)
5851 gfc_error ("Loop parallelized across gangs is not allowed "
5852 "inside loop parallelized across workers at %L",
5853 &code->loc);
5854 if (c->code->ext.omp_clauses->vector)
5855 gfc_error ("Loop parallelized across gangs is not allowed "
5856 "inside loop parallelized across vectors at %L",
5857 &code->loc);
5858 }
5859 if (code->ext.omp_clauses->worker)
5860 {
5861 if (c->code->ext.omp_clauses->worker)
5862 gfc_error ("Loop parallelized across workers is not allowed "
5863 "inside another loop parallelized across workers at %L",
5864 &code->loc);
5865 if (c->code->ext.omp_clauses->vector)
5866 gfc_error ("Loop parallelized across workers is not allowed "
5867 "inside another loop parallelized across vectors at %L",
5868 &code->loc);
5869 }
5870 if (code->ext.omp_clauses->vector)
5871 if (c->code->ext.omp_clauses->vector)
5872 gfc_error ("Loop parallelized across vectors is not allowed "
5873 "inside another loop parallelized across vectors at %L",
5874 &code->loc);
5875 }
5876
5877 if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
5878 break;
5879 }
5880
5881 if (code->ext.omp_clauses->seq)
5882 {
5883 if (code->ext.omp_clauses->independent)
5884 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
5885 if (code->ext.omp_clauses->gang)
5886 gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
5887 if (code->ext.omp_clauses->worker)
5888 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
5889 if (code->ext.omp_clauses->vector)
5890 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
5891 if (code->ext.omp_clauses->par_auto)
5892 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
5893 }
5894 if (code->ext.omp_clauses->par_auto)
5895 {
5896 if (code->ext.omp_clauses->gang)
5897 gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
5898 if (code->ext.omp_clauses->worker)
5899 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
5900 if (code->ext.omp_clauses->vector)
5901 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
5902 }
5903 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang 6175 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
5904 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) 6176 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
5905 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " 6177 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5906 "vectors at the same time at %L", &code->loc); 6178 "vectors at the same time at %L", &code->loc);
5907 6179
5948 6220
5949 void 6221 void
5950 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) 6222 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
5951 { 6223 {
5952 fortran_omp_context ctx; 6224 fortran_omp_context ctx;
6225 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
6226 gfc_omp_namelist *n;
6227 int list;
5953 6228
5954 resolve_oacc_loop_blocks (code); 6229 resolve_oacc_loop_blocks (code);
5955 6230
5956 ctx.code = code; 6231 ctx.code = code;
5957 ctx.sharing_clauses = NULL; 6232 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
5958 ctx.private_iterators = new hash_set<gfc_symbol *>; 6233 ctx.private_iterators = new hash_set<gfc_symbol *>;
5959 ctx.previous = omp_current_ctx; 6234 ctx.previous = omp_current_ctx;
5960 ctx.is_openmp = false; 6235 ctx.is_openmp = false;
5961 omp_current_ctx = &ctx; 6236 omp_current_ctx = &ctx;
5962 6237
6238 for (list = 0; list < OMP_LIST_NUM; list++)
6239 switch (list)
6240 {
6241 case OMP_LIST_PRIVATE:
6242 for (n = omp_clauses->lists[list]; n; n = n->next)
6243 ctx.sharing_clauses->add (n->sym);
6244 break;
6245 default:
6246 break;
6247 }
6248
5963 gfc_resolve_blocks (code->block, ns); 6249 gfc_resolve_blocks (code->block, ns);
5964 6250
5965 omp_current_ctx = ctx.previous; 6251 omp_current_ctx = ctx.previous;
6252 delete ctx.sharing_clauses;
5966 delete ctx.private_iterators; 6253 delete ctx.private_iterators;
5967 } 6254 }
5968 6255
5969 6256
5970 static void 6257 static void
5998 { 6285 {
5999 for (list = 0; list < OMP_LIST_NUM; list++) 6286 for (list = 0; list < OMP_LIST_NUM; list++)
6000 for (n = oc->clauses->lists[list]; n; n = n->next) 6287 for (n = oc->clauses->lists[list]; n; n = n->next)
6001 { 6288 {
6002 n->sym->mark = 0; 6289 n->sym->mark = 0;
6003 if (n->sym->attr.function || n->sym->attr.subroutine) 6290 if (n->sym->attr.flavor != FL_VARIABLE
6291 && (n->sym->attr.flavor != FL_PROCEDURE
6292 || n->sym->result != n->sym))
6004 { 6293 {
6005 gfc_error ("Object %qs is not a variable at %L", 6294 gfc_error ("Object %qs is not a variable at %L",
6006 n->sym->name, &oc->loc);
6007 continue;
6008 }
6009 if (n->sym->attr.flavor == FL_PARAMETER)
6010 {
6011 gfc_error ("PARAMETER object %qs is not allowed at %L",
6012 n->sym->name, &oc->loc); 6295 n->sym->name, &oc->loc);
6013 continue; 6296 continue;
6014 } 6297 }
6015 6298
6016 if (n->expr && n->expr->ref->type == REF_ARRAY) 6299 if (n->expr && n->expr->ref->type == REF_ARRAY)
6047 for (n = oc->clauses->lists[list]; n; n = n->next) 6330 for (n = oc->clauses->lists[list]; n; n = n->next)
6048 n->sym->mark = 0; 6331 n->sym->mark = 0;
6049 } 6332 }
6050 } 6333 }
6051 6334
6335
6336 void
6337 gfc_resolve_oacc_routines (gfc_namespace *ns)
6338 {
6339 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
6340 orn;
6341 orn = orn->next)
6342 {
6343 gfc_symbol *sym = orn->sym;
6344 if (!sym->attr.external
6345 && !sym->attr.function
6346 && !sym->attr.subroutine)
6347 {
6348 gfc_error ("NAME %qs does not refer to a subroutine or function"
6349 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
6350 continue;
6351 }
6352 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
6353 {
6354 gfc_error ("NAME %qs invalid"
6355 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
6356 continue;
6357 }
6358 }
6359 }
6360
6361
6052 void 6362 void
6053 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) 6363 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6054 { 6364 {
6055 resolve_oacc_directive_inside_omp_region (code); 6365 resolve_oacc_directive_inside_omp_region (code);
6056 6366
6057 switch (code->op) 6367 switch (code->op)
6058 { 6368 {
6059 case EXEC_OACC_PARALLEL: 6369 case EXEC_OACC_PARALLEL:
6060 case EXEC_OACC_KERNELS: 6370 case EXEC_OACC_KERNELS:
6371 case EXEC_OACC_SERIAL:
6061 case EXEC_OACC_DATA: 6372 case EXEC_OACC_DATA:
6062 case EXEC_OACC_HOST_DATA: 6373 case EXEC_OACC_HOST_DATA:
6063 case EXEC_OACC_UPDATE: 6374 case EXEC_OACC_UPDATE:
6064 case EXEC_OACC_ENTER_DATA: 6375 case EXEC_OACC_ENTER_DATA:
6065 case EXEC_OACC_EXIT_DATA: 6376 case EXEC_OACC_EXIT_DATA:
6067 case EXEC_OACC_CACHE: 6378 case EXEC_OACC_CACHE:
6068 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); 6379 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6069 break; 6380 break;
6070 case EXEC_OACC_PARALLEL_LOOP: 6381 case EXEC_OACC_PARALLEL_LOOP:
6071 case EXEC_OACC_KERNELS_LOOP: 6382 case EXEC_OACC_KERNELS_LOOP:
6383 case EXEC_OACC_SERIAL_LOOP:
6072 case EXEC_OACC_LOOP: 6384 case EXEC_OACC_LOOP:
6073 resolve_oacc_loop (code); 6385 resolve_oacc_loop (code);
6074 break; 6386 break;
6075 case EXEC_OACC_ATOMIC: 6387 case EXEC_OACC_ATOMIC:
6076 resolve_omp_atomic (code); 6388 resolve_omp_atomic (code);