Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/trans.c @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
1 /* Code translation -- generate GCC trees from gfc_code. 1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2017 Free Software Foundation, Inc. 2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook 3 Contributed by Paul Brook
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
59 t = DECL_CHAIN (t); 59 t = DECL_CHAIN (t);
60 } 60 }
61 return t; 61 return t;
62 } 62 }
63 63
64
65 /* Strip off a legitimate source ending from the input
66 string NAME of length LEN. */
67
68 static inline void
69 remove_suffix (char *name, int len)
70 {
71 int i;
72
73 for (i = 2; i < 8 && len > i; i++)
74 {
75 if (name[len - i] == '.')
76 {
77 name[len - i] = '\0';
78 break;
79 }
80 }
81 }
82
83
84 /* Creates a variable declaration with a given TYPE. */ 64 /* Creates a variable declaration with a given TYPE. */
85 65
86 tree 66 tree
87 gfc_create_var_np (tree type, const char *prefix) 67 gfc_create_var_np (tree type, const char *prefix)
88 { 68 {
318 && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF 298 && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
319 || TREE_CODE (decl) == FUNCTION_DECL 299 || TREE_CODE (decl) == FUNCTION_DECL
320 || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) 300 || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
321 == DECL_CONTEXT (decl))) 301 == DECL_CONTEXT (decl)))
322 { 302 {
323 span = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 303 span = fold_convert (gfc_array_index_type,
324 span = fold_convert (gfc_array_index_type, span); 304 TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
305 span = fold_build2 (MULT_EXPR, gfc_array_index_type,
306 fold_convert (gfc_array_index_type,
307 TYPE_SIZE_UNIT (TREE_TYPE (type))),
308 span);
309 }
310 else if (type && TREE_CODE (type) == ARRAY_TYPE
311 && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
312 && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
313 {
314 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
315 span = gfc_conv_descriptor_span_get (decl);
316 else
317 span = NULL_TREE;
325 } 318 }
326 /* Likewise for class array or pointer array references. */ 319 /* Likewise for class array or pointer array references. */
327 else if (TREE_CODE (decl) == FIELD_DECL 320 else if (TREE_CODE (decl) == FIELD_DECL
328 || VAR_OR_FUNCTION_DECL_P (decl) 321 || VAR_OR_FUNCTION_DECL_P (decl)
329 || TREE_CODE (decl) == PARM_DECL) 322 || TREE_CODE (decl) == PARM_DECL)
401 /* If decl or vptr are non-null, pointer arithmetic for the array reference 394 /* If decl or vptr are non-null, pointer arithmetic for the array reference
402 is likely. Generate the 'span' for the array reference. */ 395 is likely. Generate the 'span' for the array reference. */
403 if (vptr) 396 if (vptr)
404 span = gfc_vptr_size_get (vptr); 397 span = gfc_vptr_size_get (vptr);
405 else if (decl) 398 else if (decl)
406 span = get_array_span (type, decl); 399 {
400 if (TREE_CODE (decl) == COMPONENT_REF)
401 span = gfc_conv_descriptor_span_get (decl);
402 else
403 span = get_array_span (type, decl);
404 }
407 405
408 /* If a non-null span has been generated reference the element with 406 /* If a non-null span has been generated reference the element with
409 pointer arithmetic. */ 407 pointer arithmetic. */
410 if (span != NULL_TREE) 408 if (span != NULL_TREE)
411 { 409 {
531 if (integer_zerop (cond)) 529 if (integer_zerop (cond))
532 return; 530 return;
533 531
534 if (once) 532 if (once)
535 { 533 {
536 tmpvar = gfc_create_var (boolean_type_node, "print_warning"); 534 tmpvar = gfc_create_var (logical_type_node, "print_warning");
537 TREE_STATIC (tmpvar) = 1; 535 TREE_STATIC (tmpvar) = 1;
538 DECL_INITIAL (tmpvar) = boolean_true_node; 536 DECL_INITIAL (tmpvar) = logical_true_node;
539 gfc_add_expr_to_block (pblock, tmpvar); 537 gfc_add_expr_to_block (pblock, tmpvar);
540 } 538 }
541 539
542 gfc_start_block (&block); 540 gfc_start_block (&block);
543 541
552 trans_runtime_error_vararg (error, where, 550 trans_runtime_error_vararg (error, where,
553 msgid, ap)); 551 msgid, ap));
554 va_end (ap); 552 va_end (ap);
555 553
556 if (once) 554 if (once)
557 gfc_add_modify (&block, tmpvar, boolean_false_node); 555 gfc_add_modify (&block, tmpvar, logical_false_node);
558 556
559 body = gfc_finish_block (&block); 557 body = gfc_finish_block (&block);
560 558
561 if (integer_onep (cond)) 559 if (integer_onep (cond))
562 { 560 {
605 603
606 /* Optionally check whether malloc was successful. */ 604 /* Optionally check whether malloc was successful. */
607 if (gfc_option.rtcheck & GFC_RTCHECK_MEM) 605 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
608 { 606 {
609 null_result = fold_build2_loc (input_location, EQ_EXPR, 607 null_result = fold_build2_loc (input_location, EQ_EXPR,
610 boolean_type_node, res, 608 logical_type_node, res,
611 build_int_cst (pvoid_type_node, 0)); 609 build_int_cst (pvoid_type_node, 0));
612 msg = gfc_build_addr_expr (pchar_type_node, 610 msg = gfc_build_addr_expr (pchar_type_node,
613 gfc_build_localized_cstring_const ("Memory allocation failed")); 611 gfc_build_localized_cstring_const ("Memory allocation failed"));
614 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 612 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
615 null_result, 613 null_result,
691 ("Allocation would exceed memory limit"))); 689 ("Allocation would exceed memory limit")));
692 gfc_add_expr_to_block (&on_error, tmp); 690 gfc_add_expr_to_block (&on_error, tmp);
693 } 691 }
694 692
695 error_cond = fold_build2_loc (input_location, EQ_EXPR, 693 error_cond = fold_build2_loc (input_location, EQ_EXPR,
696 boolean_type_node, pointer, 694 logical_type_node, pointer,
697 build_int_cst (prvoid_type_node, 0)); 695 build_int_cst (prvoid_type_node, 0));
698 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 696 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
699 gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), 697 gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
700 gfc_finish_block (&on_error), 698 gfc_finish_block (&on_error),
701 build_empty_stmt (input_location)); 699 build_empty_stmt (input_location));
793 bool need_assign = false, refs_comp = false; 791 bool need_assign = false, refs_comp = false;
794 gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; 792 gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
795 793
796 size = fold_convert (size_type_node, size); 794 size = fold_convert (size_type_node, size);
797 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, 795 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
798 boolean_type_node, mem, 796 logical_type_node, mem,
799 build_int_cst (type, 0)), 797 build_int_cst (type, 0)),
800 PRED_FORTRAN_REALLOC); 798 PRED_FORTRAN_REALLOC);
801 799
802 /* If mem is NULL, we call gfc_allocate_using_malloc or 800 /* If mem is NULL, we call gfc_allocate_using_malloc or
803 gfc_allocate_using_lib. */ 801 gfc_allocate_using_lib. */
871 gfc_conv_descriptor_data_get (tmp))); 869 gfc_conv_descriptor_data_get (tmp)));
872 if (status != NULL_TREE) 870 if (status != NULL_TREE)
873 { 871 {
874 TREE_USED (label_finish) = 1; 872 TREE_USED (label_finish) = 1;
875 tmp = build1_v (GOTO_EXPR, label_finish); 873 tmp = build1_v (GOTO_EXPR, label_finish);
876 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 874 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
877 status, build_zero_cst (TREE_TYPE (status))); 875 status, build_zero_cst (TREE_TYPE (status)));
878 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 876 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
879 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), 877 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
880 tmp, build_empty_stmt (input_location)); 878 tmp, build_empty_stmt (input_location));
881 gfc_add_expr_to_block (&alloc_block, tmp); 879 gfc_add_expr_to_block (&alloc_block, tmp);
1088 if (comp->attr.allocatable 1086 if (comp->attr.allocatable
1089 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) 1087 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1090 { 1088 {
1091 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) 1089 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1092 ? gfc_conv_descriptor_data_get (array) : array; 1090 ? gfc_conv_descriptor_data_get (array) : array;
1093 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1091 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1094 tmp, fold_convert (TREE_TYPE (tmp), 1092 tmp, fold_convert (TREE_TYPE (tmp),
1095 null_pointer_node)); 1093 null_pointer_node));
1096 } 1094 }
1097 else 1095 else
1098 cond = boolean_true_node; 1096 cond = logical_true_node;
1099 1097
1100 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) 1098 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1101 { 1099 {
1102 gfc_clear_attr (&attr); 1100 gfc_clear_attr (&attr);
1103 gfc_init_se (&se, NULL); 1101 gfc_init_se (&se, NULL);
1109 if (!POINTER_TYPE_P (TREE_TYPE (array))) 1107 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1110 array = gfc_build_addr_expr (NULL, array); 1108 array = gfc_build_addr_expr (NULL, array);
1111 1109
1112 if (!final_expr) 1110 if (!final_expr)
1113 { 1111 {
1114 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1112 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1115 final_fndecl, 1113 final_fndecl,
1116 fold_convert (TREE_TYPE (final_fndecl), 1114 fold_convert (TREE_TYPE (final_fndecl),
1117 null_pointer_node)); 1115 null_pointer_node));
1118 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1116 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1119 boolean_type_node, cond, tmp); 1117 logical_type_node, cond, tmp);
1120 } 1118 }
1121 1119
1122 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) 1120 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1123 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); 1121 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1124 1122
1210 gfc_se se; 1208 gfc_se se;
1211 1209
1212 gfc_init_se (&se, NULL); 1210 gfc_init_se (&se, NULL);
1213 se.want_pointer = 1; 1211 se.want_pointer = 1;
1214 gfc_conv_expr (&se, final_expr); 1212 gfc_conv_expr (&se, final_expr);
1215 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1213 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1216 se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); 1214 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
1217 1215
1218 /* For CLASS(*) not only sym->_vtab->_final can be NULL 1216 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1219 but already sym->_vtab itself. */ 1217 but already sym->_vtab itself. */
1220 if (UNLIMITED_POLY (expr)) 1218 if (UNLIMITED_POLY (expr))
1228 gfc_init_se (&se, NULL); 1226 gfc_init_se (&se, NULL);
1229 se.want_pointer = 1; 1227 se.want_pointer = 1;
1230 gfc_conv_expr (&se, vptr_expr); 1228 gfc_conv_expr (&se, vptr_expr);
1231 gfc_free_expr (vptr_expr); 1229 gfc_free_expr (vptr_expr);
1232 1230
1233 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1231 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1234 se.expr, 1232 se.expr,
1235 build_int_cst (TREE_TYPE (se.expr), 0)); 1233 build_int_cst (TREE_TYPE (se.expr), 0));
1236 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1234 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1237 boolean_type_node, cond2, cond); 1235 logical_type_node, cond2, cond);
1238 } 1236 }
1239 1237
1240 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1238 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1241 cond, tmp, build_empty_stmt (input_location)); 1239 cond, tmp, build_empty_stmt (input_location));
1242 } 1240 }
1338 pointer = gfc_conv_descriptor_data_get (pointer); 1336 pointer = gfc_conv_descriptor_data_get (pointer);
1339 } 1337 }
1340 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) 1338 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1341 pointer = gfc_conv_descriptor_data_get (pointer); 1339 pointer = gfc_conv_descriptor_data_get (pointer);
1342 1340
1343 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, 1341 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1344 build_int_cst (TREE_TYPE (pointer), 0)); 1342 build_int_cst (TREE_TYPE (pointer), 0));
1345 1343
1346 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise 1344 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1347 we emit a runtime error. */ 1345 we emit a runtime error. */
1348 gfc_start_block (&null); 1346 gfc_start_block (&null);
1365 if (status != NULL_TREE && !integer_zerop (status)) 1363 if (status != NULL_TREE && !integer_zerop (status))
1366 { 1364 {
1367 tree cond2; 1365 tree cond2;
1368 1366
1369 status_type = TREE_TYPE (TREE_TYPE (status)); 1367 status_type = TREE_TYPE (TREE_TYPE (status));
1370 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1368 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1371 status, build_int_cst (TREE_TYPE (status), 0)); 1369 status, build_int_cst (TREE_TYPE (status), 0));
1372 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1370 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1373 fold_build1_loc (input_location, INDIRECT_REF, 1371 fold_build1_loc (input_location, INDIRECT_REF,
1374 status_type, status), 1372 status_type, status),
1375 build_int_cst (status_type, 1)); 1373 build_int_cst (status_type, 1));
1398 { 1396 {
1399 /* We set STATUS to zero if it is present. */ 1397 /* We set STATUS to zero if it is present. */
1400 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1398 tree status_type = TREE_TYPE (TREE_TYPE (status));
1401 tree cond2; 1399 tree cond2;
1402 1400
1403 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1401 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1404 status, 1402 status,
1405 build_int_cst (TREE_TYPE (status), 0)); 1403 build_int_cst (TREE_TYPE (status), 0));
1406 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1404 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1407 fold_build1_loc (input_location, INDIRECT_REF, 1405 fold_build1_loc (input_location, INDIRECT_REF,
1408 status_type, status), 1406 status_type, status),
1461 build_int_cst (TREE_TYPE (pointer), 1459 build_int_cst (TREE_TYPE (pointer),
1462 0)); 1460 0));
1463 1461
1464 TREE_USED (label_finish) = 1; 1462 TREE_USED (label_finish) = 1;
1465 tmp = build1_v (GOTO_EXPR, label_finish); 1463 tmp = build1_v (GOTO_EXPR, label_finish);
1466 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1464 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1467 stat, build_zero_cst (TREE_TYPE (stat))); 1465 stat, build_zero_cst (TREE_TYPE (stat)));
1468 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1466 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1469 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), 1467 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1470 tmp, nullify); 1468 tmp, nullify);
1471 gfc_add_expr_to_block (&non_null, tmp); 1469 gfc_add_expr_to_block (&non_null, tmp);
1497 1495
1498 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp 1496 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1499 && comp_ref) 1497 && comp_ref)
1500 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; 1498 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1501 1499
1502 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, 1500 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1503 build_int_cst (TREE_TYPE (pointer), 0)); 1501 build_int_cst (TREE_TYPE (pointer), 0));
1504 1502
1505 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise 1503 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1506 we emit a runtime error. */ 1504 we emit a runtime error. */
1507 gfc_start_block (&null); 1505 gfc_start_block (&null);
1524 if (status != NULL_TREE && !integer_zerop (status)) 1522 if (status != NULL_TREE && !integer_zerop (status))
1525 { 1523 {
1526 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1524 tree status_type = TREE_TYPE (TREE_TYPE (status));
1527 tree cond2; 1525 tree cond2;
1528 1526
1529 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1527 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1530 status, build_int_cst (TREE_TYPE (status), 0)); 1528 status, build_int_cst (TREE_TYPE (status), 0));
1531 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1529 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1532 fold_build1_loc (input_location, INDIRECT_REF, 1530 fold_build1_loc (input_location, INDIRECT_REF,
1533 status_type, status), 1531 status_type, status),
1534 build_int_cst (status_type, 1)); 1532 build_int_cst (status_type, 1));
1569 { 1567 {
1570 /* We set STATUS to zero if it is present. */ 1568 /* We set STATUS to zero if it is present. */
1571 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1569 tree status_type = TREE_TYPE (TREE_TYPE (status));
1572 tree cond2; 1570 tree cond2;
1573 1571
1574 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1572 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1575 status, 1573 status,
1576 build_int_cst (TREE_TYPE (status), 0)); 1574 build_int_cst (TREE_TYPE (status), 0));
1577 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1575 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1578 fold_build1_loc (input_location, INDIRECT_REF, 1576 fold_build1_loc (input_location, INDIRECT_REF,
1579 status_type, status), 1577 status_type, status),
1619 tree stat = build_fold_indirect_ref_loc (input_location, status); 1617 tree stat = build_fold_indirect_ref_loc (input_location, status);
1620 tree cond2; 1618 tree cond2;
1621 1619
1622 TREE_USED (label_finish) = 1; 1620 TREE_USED (label_finish) = 1;
1623 tmp = build1_v (GOTO_EXPR, label_finish); 1621 tmp = build1_v (GOTO_EXPR, label_finish);
1624 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 1622 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1625 stat, build_zero_cst (TREE_TYPE (stat))); 1623 stat, build_zero_cst (TREE_TYPE (stat)));
1626 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1624 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1627 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), 1625 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1628 tmp, build_empty_stmt (input_location)); 1626 tmp, build_empty_stmt (input_location));
1629 gfc_add_expr_to_block (&non_null, tmp); 1627 gfc_add_expr_to_block (&non_null, tmp);
1662 /* Call realloc and check the result. */ 1660 /* Call realloc and check the result. */
1663 tmp = build_call_expr_loc (input_location, 1661 tmp = build_call_expr_loc (input_location,
1664 builtin_decl_explicit (BUILT_IN_REALLOC), 2, 1662 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1665 fold_convert (pvoid_type_node, mem), size); 1663 fold_convert (pvoid_type_node, mem), size);
1666 gfc_add_modify (block, res, fold_convert (type, tmp)); 1664 gfc_add_modify (block, res, fold_convert (type, tmp));
1667 null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 1665 null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
1668 res, build_int_cst (pvoid_type_node, 0)); 1666 res, build_int_cst (pvoid_type_node, 0));
1669 nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size, 1667 nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
1670 build_int_cst (size_type_node, 0)); 1668 build_int_cst (size_type_node, 0));
1671 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, 1669 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
1672 null_result, nonzero); 1670 null_result, nonzero);
1673 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const 1671 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1674 ("Allocation would exceed memory limit")); 1672 ("Allocation would exceed memory limit"));
1675 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1673 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1676 null_result, 1674 null_result,
1964 res = gfc_trans_fail_image (code); 1962 res = gfc_trans_fail_image (code);
1965 break; 1963 break;
1966 1964
1967 case EXEC_FORALL: 1965 case EXEC_FORALL:
1968 res = gfc_trans_forall (code); 1966 res = gfc_trans_forall (code);
1967 break;
1968
1969 case EXEC_FORM_TEAM:
1970 res = gfc_trans_form_team (code);
1971 break;
1972
1973 case EXEC_CHANGE_TEAM:
1974 res = gfc_trans_change_team (code);
1975 break;
1976
1977 case EXEC_END_TEAM:
1978 res = gfc_trans_end_team (code);
1979 break;
1980
1981 case EXEC_SYNC_TEAM:
1982 res = gfc_trans_sync_team (code);
1969 break; 1983 break;
1970 1984
1971 case EXEC_WHERE: 1985 case EXEC_WHERE:
1972 res = gfc_trans_where (code); 1986 res = gfc_trans_where (code);
1973 break; 1987 break;