diff options
Diffstat (limited to 'gcc/fortran/trans-expr.cc')
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 37 |
1 files changed, 30 insertions, 7 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 19e5669b..3e0d763 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2782,9 +2782,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2795,6 +2797,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr, + build_one_cst (gfc_charlen_type_node)); + diff = fold_convert (size_type_node, diff); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ @@ -4625,6 +4636,16 @@ get_builtin_fn (gfc_symbol * sym) && !strcmp (sym->name, "omp_is_initial_device")) return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE); + if (!gfc_option.disable_omp_get_initial_device + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_initial_device")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE); + + if (!gfc_option.disable_omp_get_num_devices + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_num_devices")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + if (!gfc_option.disable_acc_on_device && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL && !strcmp (sym->name, "acc_on_device_h")) @@ -8145,7 +8166,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, goto end_pointer_check; tmp = parmse.expr; - if (fsym && fsym->ts.type == BT_CLASS) + if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer) { if (POINTER_TYPE_P (TREE_TYPE (tmp))) tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -10912,9 +10933,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&lse, NULL); /* Usually testing whether this is not a proc pointer assignment. */ - non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer - && expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE); + non_proc_ptr_assign + = !(gfc_expr_attr (expr1).proc_pointer + && ((expr2->expr_type == EXPR_VARIABLE + && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE) + || expr2->expr_type == EXPR_NULL)); /* Check whether the expression is a scalar or not; we cannot use expr1->rank as it can be nonzero for proc pointers. */ |