diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/check.cc | 36 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.cc | 11 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/iso-c-binding.def | 3 | ||||
| -rw-r--r-- | gcc/fortran/primary.cc | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 182 |
7 files changed, 230 insertions, 9 deletions
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index f4fde83..08cc88b 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1829,6 +1829,42 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team) } +/* Check the arguments for f_c_string. */ + +bool +gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis) +{ + + if (gfc_invalid_null_arg (string)) + return false; + + if (!scalar_check (string, 0)) + return false; + + if (string->ts.type != BT_CHARACTER + || (string->ts.type == BT_CHARACTER + && (string->ts.kind != gfc_default_character_kind))) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall have " + "a type of CHARACTER(KIND=C_CHAR)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &string->where); + return false; + } + + if (asis) + { + if (!type_check (asis, 1, BT_LOGICAL)) + return false; + + if (!scalar_check (asis, 1)) + return false; + } + + return true; +} + + bool gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 87307c5..a2c8ebc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -508,6 +508,7 @@ enum gfc_isym_id GFC_ISYM_EXP, GFC_ISYM_EXPONENT, GFC_ISYM_EXTENDS_TYPE_OF, + GFC_ISYM_F_C_STRING, GFC_ISYM_FAILED_IMAGES, GFC_ISYM_FDATE, GFC_ISYM_FE_RUNTIME_ERROR, diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index a2e2412..d4db6ab 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -3145,6 +3145,14 @@ add_functions (void) x, BT_UNKNOWN, 0, REQUIRED); make_from_module(); + add_sym_2 ("f_c_string", GFC_ISYM_F_C_STRING, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F2023, + gfc_check_f_c_string, NULL, NULL, + stg, BT_CHARACTER, dc, REQUIRED, + "asis", BT_CHARACTER, dc, OPTIONAL); + make_from_module(); + add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008, gfc_check_c_sizeof, gfc_simplify_sizeof, NULL, @@ -3301,7 +3309,8 @@ add_functions (void) make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95); - add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, + add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim, stg, BT_CHARACTER, dc, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 61d85ee..640d1bc 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_dtime_etime (gfc_expr *); bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_f_c_string (gfc_expr *, gfc_expr *); bool gfc_check_failed_or_stopped_images (gfc_expr *, gfc_expr *); bool gfc_check_fgetputc (gfc_expr *, gfc_expr *); bool gfc_check_fgetput (gfc_expr *); diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def index bad66b1..5ef4368 100644 --- a/gcc/fortran/iso-c-binding.def +++ b/gcc/fortran/iso-c-binding.def @@ -256,6 +256,9 @@ NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc", NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \ GFC_ISYM_C_SIZEOF, GFC_STD_F2008) +NAMED_FUNCTION (ISOCBINDING_F_C_STRING, "f_c_string", \ + GFC_ISYM_F_C_STRING, GFC_STD_F2023) + #undef NAMED_INTCST #undef NAMED_UINTCST #undef NAMED_REALCST diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index ab49eac..86c16af 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -4039,12 +4039,11 @@ gfc_match_rvalue (gfc_expr **result) } /* Check here for the existence of at least one argument for the - iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The - argument(s) given will be checked in gfc_iso_c_func_interface, - during resolution of the function call. */ + iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. */ if (sym->attr.is_iso_c == 1 && (sym->from_intmod == INTMOD_ISO_C_BINDING && (sym->intmod_sym_id == ISOCBINDING_LOC + || sym->intmod_sym_id == ISOCBINDING_F_C_STRING || sym->intmod_sym_id == ISOCBINDING_FUNLOC || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED))) { diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 66da97b..edc4a87 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -10024,11 +10024,39 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) } -/* The following routine generates code for the intrinsic - functions from the ISO_C_BINDING module: - * C_LOC - * C_FUNLOC - * C_ASSOCIATED */ +/* Specialized trim for f_c_string. */ + +static void +conv_trim (gfc_se *tse, gfc_se *str) +{ + tree cond, plen, pvar, tlen, ttmp, tvar; + + tlen = gfc_create_var (gfc_charlen_type_node, "tlen"); + plen = gfc_build_addr_expr (NULL_TREE, tlen); + + tvar = gfc_create_var (pchar_type_node, "tstr"); + pvar = gfc_build_addr_expr (ppvoid_type_node, tvar); + + ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4, + plen, pvar, str->string_length, str->expr); + + gfc_add_expr_to_block (&tse->pre, ttmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + tlen, build_int_cst (TREE_TYPE (tlen), 0)); + ttmp = gfc_call_free (tvar); + ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&tse->post, ttmp); + + tse->expr = tvar; + tse->string_length = tlen; +} + + +/* The following routine generates code for the intrinsic functions from + the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and + F_C_STRING. */ static void conv_isocbinding_function (gfc_se *se, gfc_expr *expr) @@ -10103,6 +10131,149 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr) not_null_expr, eq_expr); } } + else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING) + { + /* There are three cases: + f_c_string(string) -> trim(string) // c_null_char + f_c_string(string, .false.) -> trim(string) // c_null_char + f_c_string(string, .true.) -> string // c_null_char */ + + gfc_se lse, rse, tse; + tree len, tmp, var; + gfc_expr *string = arg->expr; + gfc_expr *asis = arg->next->expr; + gfc_expr *cnc; + + /* Convert string. */ + gfc_init_se (&lse, se); + gfc_conv_expr (&lse, string); + gfc_conv_string_parameter (&lse); + + /* Create a string for C_NULL_CHAR and convert it. */ + cnc = gfc_get_character_expr (gfc_default_character_kind, + &string->where, "\0", 1); + gfc_init_se (&rse, se); + gfc_conv_expr (&rse, cnc); + gfc_conv_string_parameter (&rse); + gfc_free_expr (cnc); + +#ifdef cnode +#undef cnode +#endif +#define cnode gfc_charlen_type_node + if (asis) + { + stmtblock_t block; + gfc_se asis_se, vse; + tree elen, evar, tlen, tvar; + tree else_branch, then_branch; + + elen = evar = tlen = tvar = NULL_TREE; + + /* f_c_string(string, .true.) -> string // c_null_char */ + + gfc_init_block (&block); + + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode, + fold_convert (cnode, lse.string_length), + fold_convert (cnode, rse.string_length)); + + gfc_init_se (&vse, se); + tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen); + gfc_add_block_to_block (&block, &vse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string, + 6, tlen, tvar, + lse.string_length, lse.expr, + rse.string_length, rse.expr); + gfc_add_expr_to_block (&block, tmp); + + then_branch = gfc_finish_block (&block); + + /* f_c_string(string, .false.) = trim(string) // c_null_char */ + + gfc_init_block (&block); + + gfc_init_se (&tse, se); + conv_trim (&tse, &lse); + gfc_add_block_to_block (&block, &tse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + elen = fold_build2_loc (input_location, PLUS_EXPR, cnode, + fold_convert (cnode, tse.string_length), + fold_convert (cnode, rse.string_length)); + + gfc_init_se (&vse, se); + evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen); + gfc_add_block_to_block (&block, &vse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string, + 6, elen, evar, + tse.string_length, tse.expr, + rse.string_length, rse.expr); + gfc_add_expr_to_block (&block, tmp); + + else_branch = gfc_finish_block (&block); + + gfc_init_se (&asis_se, se); + gfc_conv_expr (&asis_se, asis); + if (asis->expr_type == EXPR_VARIABLE + && asis->symtree->n.sym->attr.dummy + && asis->symtree->n.sym->attr.optional) + { + tree present = gfc_conv_expr_present (asis->symtree->n.sym); + asis_se.expr = build3_loc (input_location, COND_EXPR, + logical_type_node, present, + asis_se.expr, + build_int_cst (logical_type_node, 0)); + } + gfc_add_block_to_block (&se->pre, &asis_se.pre); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + asis_se.expr, then_branch, else_branch); + + gfc_add_expr_to_block (&se->pre, tmp); + + var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node, + asis_se.expr, tvar, evar); + gfc_add_expr_to_block (&se->pre, var); + + len = fold_build3_loc (input_location, COND_EXPR, cnode, + asis_se.expr, tlen, elen); + gfc_add_expr_to_block (&se->pre, len); + } + else + { + /* f_c_string(string) = trim(string) // c_null_char */ + + gfc_add_block_to_block (&se->pre, &lse.pre); + gfc_add_block_to_block (&se->pre, &rse.pre); + + gfc_init_se (&tse, se); + conv_trim (&tse, &lse); + gfc_add_block_to_block (&se->pre, &tse.pre); + gfc_add_block_to_block (&se->post, &tse.post); + + len = fold_build2_loc (input_location, PLUS_EXPR, cnode, + fold_convert (cnode, tse.string_length), + fold_convert (cnode, rse.string_length)); + + var = gfc_conv_string_tmp (se, pchar_type_node, len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string, + 6, len, var, + tse.string_length, tse.expr, + rse.string_length, rse.expr); + gfc_add_expr_to_block (&se->pre, tmp); + } + + se->expr = var; + se->string_length = len; + +#undef cnode + } else gcc_unreachable (); } @@ -11243,6 +11414,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_C_ASSOCIATED: case GFC_ISYM_C_FUNLOC: case GFC_ISYM_C_LOC: + case GFC_ISYM_F_C_STRING: conv_isocbinding_function (se, expr); break; |