diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 167 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/frontend-passes.c | 27 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.texi | 51 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 1 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 34 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/trans-const.c | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 93 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 23 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 29 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 70 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 1 |
19 files changed, 470 insertions, 133 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 01e2a906443..9be8a0dfe09 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,166 @@ +2018-02-23 Steven G. Kargl <kargl@gcc.gnu.org> + + * intrinsic.texi: Arguments to MATMUL cannot both be rank one. + +2018-02-23 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/84511 + * trans-io.c (transfer_expr): Deal with C_LOC in transfer statement. + +2018-02-23 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/84346 + * interface.c (compare_actual_formal): Issue error if keyword is + used in a statement function. + +2018-02-23 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/84506 + * trans-io.c (set_parameter_value_inquire): Adjust range check of + negative unit values for kind=8 units to the kind=4 negative limit. + +2018-02-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83149 + * trans-types.c (gfc_sym_type): Test sym->ns->proc_name before + accessing its components. + +2018-02-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83149 + * trans-decl.c (gfc_finish_var_decl): Test sym->ns->proc_name + before accessing its components. + +2018-02-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83148 + * trans-const.c : Clean up some whitespace issues. + * trans-expr.c (gfc_conv_initializer): If an iso_c_binding + derived type has a kind value of zero, set it to the default + integer kind. + +2018-02-23 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/84519 + * trans-decl.c (gfc_build_builtin_function_decls): Add bool + argument to stop and error stop decls. + * trans-stmt.c (gfc_trans_stop): Add false value to argument + lists. + +2018-02-22 Janne Blomqvist <jb@gcc.gnu.org> + + PR 78534 + PR 84509 + * trans-decl.c (gfc_build_builtin_function_decls): Pass + gfc_int8_type node to pause_numeric, size_type_node to + pause_string. + * trans-stmt.c (gfc_trans_pause): Likewise. + +2018-02-22 Janne Blomqvist <jb@gcc.gnu.org> + + * gfortran.texi: Update Coarray API description. + * trans-decl.c (gfc_build_builtin_function_decls): Use size_t for + character lengths, int for exit codes. + (generate_coarray_sym_init): Use size_t for character length. + * trans-intrinsic.c (conv_co_collective): Likewise. + * trans-stmt.c (gfc_trans_lock_unlock): Likewise. + (gfc_trans_event_post_wait): Likewise. + (gfc_trans_sync): Likewise. + (gfc_trans_stop): Use size_t for character lengths, int for exit + codes. + +2018-02-20 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/48890 + PR fortran/83823 + * primary.c (gfc_convert_to_structure_constructor): + For a constant string constructor, make sure the length + is correct. + +2018-02-19 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83344 + PR fortran/83975 + * resolve.c (resolve_assoc_var): Rearrange the logic for the + determination of the character length of associate names. If + the associate name is missing a length expression or the length + expression is not a constant and the target is not a variable, + make the associate name allocatable and deferred length. + * trans-decl.c (gfc_get_symbol_decl): Null the character length + backend_decl for deferred length associate names that are not + variables. Set 'length' to gfc_index_zero_node for character + associate names, whose character length is a PARM_DECL. + +2018-02-19 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/35339 + * frontend-passes.c (traverse_io_block): Remove workaround for + PR 80945. + +2018-02-19 Andre Vehreschild <vehre@gcc.gnu.org> + + * gfortran.texi: Document additional src/dst_type. Fix some typos. + * trans-decl.c (gfc_build_builtin_function_decls): Declare the new + argument of _caf_*_by_ref () with * e { get, send, sendget }. + * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Add the type of the + data referenced when generating a call to caf_get_by_ref (). + (conv_caf_send): Same but for caf_send_by_ref () and + caf_sendget_by_ref (). + +2018-02-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/84389 + * io.c (check_format): Allow FMT_COLON. + +2018-02-18 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/80945 + * trans-array.c (gfc_conv_expr_descriptor): Set parmtype from + the typenode in the case of deferred length characters. + +2018-02-17 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/84270 + * frontend-passes (scalarized_expr): If the expression + is an assumed size array, leave in the last reference + and pass AR_SECTION instead of AR_FULL to gfc_resolve + in order to avoid an error. + +2018-02-17 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/84115 + * resolve.c (resolve_assoc_var): If a non-constant target expr. + has no string length expression, make the associate variable + into a deferred length, allocatable symbol. + * trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to + the symbol. + * trans-stmt.c (trans_associate_var): Null and free scalar + associate names that are allocatable. After assignment, remove + the allocatable attribute to prevent reallocation. + +2018-02-16 Jakub Jelinek <jakub@redhat.com> + + PR fortran/84418 + * trans-openmp.c (gfc_trans_omp_clauses): For OMP_CLAUSE_LINEAR_REF + kind set OMP_CLAUSE_LINEAR_STEP to TYPE_SIZE_UNIT times last_step. + +2018-02-16 Dominique d'Humieres <dominiq@gcc.gnu.org> + + PR fortran/84354 + * decl.c (gfc_get_pdt_instance): Replace '%qs' with %qs. + +2018-02-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/84409 + * interface.c (check_dtio_arg_TKR_intent): Add a check for character + length. + +2018-02-14 Janus Weil <janus@gcc.gnu.org> + + PR fortran/84385 + * match.c (gfc_match_select_type): Fix check for selector in + SELECT TYPE statement. + 2018-02-13 Janus Weil <janus@gcc.gnu.org> PR fortran/84313 @@ -373,7 +536,7 @@ * trans-io.c (get_dtio_proc): Likewise. (transfer_expr): Fix whitespace. -2018-01-13 Thomas Koenig <tkoenig@gcc.gnu.org> +2018-01-13 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/83744 * dump-parse-tree.c (get_c_type_name): Remove extra line. @@ -397,7 +560,7 @@ * trans-array.c (is_pointer_array): Remove unconditional return of false for -fopenmp. -2018-01-13 Thomas Koenig <tkoenig@gcc.gnu.org> +2018-01-13 Thomas Koenig <tkoenig@gcc.gnu.org> <emsr@gcc.gnu.org> PR fortran/83803 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 307caa215d6..e275be3a950 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3302,7 +3302,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, kind_expr = gfc_copy_expr (c1->initializer); else if (!(actual_param && param->attr.pdt_len)) { - gfc_error ("The derived parameter '%qs' at %C does not " + gfc_error ("The derived parameter %qs at %C does not " "have a default value", param->name); goto error_return; } @@ -3362,14 +3362,14 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, && (actual_param->spec_type == SPEC_ASSUMED || actual_param->spec_type == SPEC_DEFERRED)) { - gfc_error ("The KIND parameter '%qs' at %C cannot either be " + gfc_error ("The KIND parameter %qs at %C cannot either be " "ASSUMED or DEFERRED", param->name); goto error_return; } if (!kind_expr || !gfc_is_constant_expr (kind_expr)) { - gfc_error ("The value for the KIND parameter '%qs' at %C does not " + gfc_error ("The value for the KIND parameter %qs at %C does not " "reduce to a constant expression", param->name); goto error_return; } diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 11a5b9b779c..1ffd27d686a 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -1162,14 +1162,7 @@ traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) gcc_assert (curr->op == EXEC_TRANSFER); - /* FIXME: Workaround for PR 80945 - array slices with deferred character - lenghts do not work. Remove this section when the PR is fixed. */ e = curr->expr1; - if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER - && e->ts.deferred) - return false; - /* End of section to be removed. */ - ref = e->ref; if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next) return false; @@ -3567,10 +3560,26 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) is the lbound of a full ref. */ int j; gfc_array_ref *ar; + int to; ar = &ref->u.ar; - ar->type = AR_FULL; - for (j = 0; j < ar->dimen; j++) + + /* For assumed size, we need to keep around the final + reference in order not to get an error on resolution + below, and we cannot use AR_FULL. */ + + if (ar->as->type == AS_ASSUMED_SIZE) + { + ar->type = AR_SECTION; + to = ar->dimen - 1; + } + else + { + to = ar->dimen; + ar->type = AR_FULL; + } + + for (j = 0; j < to; j++) { gfc_free_expr (ar->start[j]); ar->start[j] = NULL; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9ffe6ade661..6f894816c62 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4458,7 +4458,7 @@ in the @var{DESC}'s data-ptr is registered or allocate when the data-ptr is @item @emph{Syntax}: @code{void caf_register (size_t size, caf_register_t type, caf_token_t *token, -gfc_descriptor_t *desc, int *stat, char *errmsg, int errmsg_len)} +gfc_descriptor_t *desc, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4510,7 +4510,7 @@ during a call to @code{_gfortran_caf_register}. @item @emph{Syntax}: @code{void caf_deregister (caf_token_t *token, caf_deregister_t type, -int *stat, char *errmsg, int errmsg_len)} +int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4750,7 +4750,7 @@ remote image identified by the @var{image_index}. @item @emph{Syntax}: @code{void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat)} +bool may_require_tmp, bool dst_reallocatable, int *stat, int dst_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4774,6 +4774,9 @@ is a full array or component ref. @item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{dst_type} @tab intent(in) Give the type of the destination. When +the destination is not an array, than the precise type, e.g. of a component in +a derived type, is not known, but provided here. @end multitable @item @emph{NOTES} @@ -4808,7 +4811,7 @@ identified by the @var{image_index}. @item @emph{Syntax}: @code{void _gfortran_caf_get_by_ref (caf_token_t token, int image_index, caf_reference_t *refs, gfc_descriptor_t *dst, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat)} +bool may_require_tmp, bool dst_reallocatable, int *stat, int src_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4833,6 +4836,9 @@ array or a component is referenced. @item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{src_type} @tab intent(in) Give the type of the source. When the +source is not an array, than the precise type, e.g. of a component in a +derived type, is not known, but provided here. @end multitable @item @emph{NOTES} @@ -4868,7 +4874,8 @@ identified by the @var{src_image_index} to a remote image identified by the @code{void _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs, caf_token_t src_token, int src_image_index, caf_reference_t *src_refs, -int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, int *src_stat)} +int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, +int *src_stat, int dst_type, int src_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4899,6 +4906,12 @@ program is terminated. the get-operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{dst_type} @tab intent(in) Give the type of the destination. When +the destination is not an array, than the precise type, e.g. of a component in +a derived type, is not known, but provided here. +@item @var{src_type} @tab intent(in) Give the type of the source. When the +source is not an array, than the precise type, e.g. of a component in a +derived type, is not known, but provided here. @end multitable @item @emph{NOTES} @@ -4936,7 +4949,7 @@ which has already been locked by the same image is an error. @item @emph{Syntax}: @code{void _gfortran_caf_lock (caf_token_t token, size_t index, int image_index, -int *aquired_lock, int *stat, char *errmsg, int errmsg_len)} +int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4971,7 +4984,7 @@ which is unlocked or has been locked by a different image is an error. @item @emph{Syntax}: @code{void _gfortran_caf_unlock (caf_token_t token, size_t index, int image_index, -int *stat, char *errmsg, int errmsg_len)} +int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5003,7 +5016,7 @@ Increment the event count of the specified event variable. @item @emph{Syntax}: @code{void _gfortran_caf_event_post (caf_token_t token, size_t index, -int image_index, int *stat, char *errmsg, int errmsg_len)} +int image_index, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5040,7 +5053,7 @@ amount and return. @item @emph{Syntax}: @code{void _gfortran_caf_event_wait (caf_token_t token, size_t index, -int until_count, int *stat, char *errmsg, int errmsg_len)} +int until_count, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5118,7 +5131,7 @@ current team. Additionally, it ensures that all pending data transfers of previous segment have completed. @item @emph{Syntax}: -@code{void _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len)} +@code{void _gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5146,7 +5159,7 @@ transfers of previous segments have completed. @item @emph{Syntax}: @code{void _gfortran_caf_sync_images (int count, int images[], int *stat, -char *errmsg, int errmsg_len)} +char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5174,7 +5187,7 @@ Acts as optimization barrier between different segments. It also ensures that all pending memory operations of this image have been completed. @item @emph{Syntax}: -@code{void _gfortran_caf_sync_memory (int *stat, char *errmsg, int errmsg_len)} +@code{void _gfortran_caf_sync_memory (int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5201,7 +5214,7 @@ function should terminate the program with the specified exit code. @item @emph{Syntax}: -@code{void _gfortran_caf_error_stop (int32_t error)} +@code{void _gfortran_caf_error_stop (int error)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5221,7 +5234,7 @@ Invoked for an @code{ERROR STOP} statement which has a string as argument. The function should terminate the program with a nonzero-exit code. @item @emph{Syntax}: -@code{void _gfortran_caf_error_stop (const char *string, int32_t len)} +@code{void _gfortran_caf_error_stop (const char *string, size_t len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5399,7 +5412,7 @@ be called collectively. @item @emph{Syntax}: @code{void _gfortran_caf_co_broadcast (gfc_descriptor_t *a, -int source_image, int *stat, char *errmsg, int errmsg_len)} +int source_image, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5430,7 +5443,7 @@ strings. @item @emph{Syntax}: @code{void _gfortran_caf_co_max (gfc_descriptor_t *a, int result_image, -int *stat, char *errmsg, int a_len, int errmsg_len)} +int *stat, char *errmsg, int a_len, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5467,7 +5480,7 @@ strings. @item @emph{Syntax}: @code{void _gfortran_caf_co_min (gfc_descriptor_t *a, int result_image, -int *stat, char *errmsg, int a_len, int errmsg_len)} +int *stat, char *errmsg, int a_len, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5503,7 +5516,7 @@ specified image. This function operates on numeric values only. @item @emph{Syntax}: @code{void _gfortran_caf_co_sum (gfc_descriptor_t *a, int result_image, -int *stat, char *errmsg, int errmsg_len)} +int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5548,7 +5561,7 @@ string lengths shall be specified as hidden arguments; @item @emph{Syntax}: @code{void _gfortran_caf_co_reduce (gfc_descriptor_t *a, void * (*opr) (void *, void *), int opr_flags, int result_image, -int *stat, char *errmsg, int a_len, int errmsg_len)} +int *stat, char *errmsg, int a_len, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index a5f3f4dda16..cb326e55c75 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2865,6 +2865,13 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, for (a = actual; a; a = a->next, f = f->next) { + if (a->name != NULL && in_statement_function) + { + gfc_error ("Keyword argument %qs at %L is invalid in " + "a statement function", a->name, &a->expr->where); + return false; + } + /* Look for keywords but ignore g77 extensions like %VAL. */ if (a->name != NULL && a->name[0] != '%') { @@ -4673,7 +4680,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* The following three functions check that the formal arguments of user defined derived type IO procedures are compliant with - the requirements of the standard. */ + the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */ static void check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, @@ -4702,6 +4709,10 @@ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, gfc_error ("DTIO dummy argument at %L must be an " "ASSUMED SHAPE ARRAY", &fsym->declared_at); + if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL) + gfc_error ("DTIO character argument at %L must have assumed length", + &fsym->declared_at); + if (fsym->attr.intent != intent) gfc_error ("DTIO dummy argument at %L must have INTENT %s", &fsym->declared_at, gfc_code2string (intents, (int)intent)); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index fbe9938b0e3..496b8dad4a7 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -9870,6 +9870,7 @@ one or two. type; otherwise, an array of @code{LOGICAL} type. The rank shall be one or two, and the first (or only) dimension of @var{MATRIX_B} shall be equal to the last (or only) dimension of @var{MATRIX_A}. +@var{MATRIX_A} and @var{MATRIX_B} shall not both be rank one arrays. @end multitable @item @emph{Return value}: diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 9b7c2de16f4..d9f0fb1d4ac 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -985,6 +985,9 @@ data_desc: case FMT_COMMA: goto format_item; + case FMT_COLON: + goto format_item_1; + case FMT_LPAREN: dtio_vlist: diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 9313f435ffb..8f3a027c209 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -6201,9 +6201,10 @@ gfc_match_select_type (void) || CLASS_DATA (expr1)->attr.codimension) && expr1->ref && expr1->ref->type == REF_ARRAY + && expr1->ref->u.ar.type == AR_FULL && expr1->ref->next == NULL); - /* Check for F03:C811. */ + /* Check for F03:C811 (F08:C835). */ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || (!class_array && expr1->ref != NULL))) { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 3d076736fdc..d889ed10ac3 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2082,7 +2082,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { bool permissible; - /* These target expressions can ge resolved at any time. */ + /* These target expressions can be resolved at any time. */ permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym && (tgt_expr->symtree->n.sym->attr.use_assoc || tgt_expr->symtree->n.sym->attr.host_assoc @@ -2879,6 +2879,38 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c if (!this_comp) goto cleanup; + /* For a constant string constructor, make sure the length is + correct; truncate of fill with blanks if needed. */ + if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable + && this_comp->ts.u.cl && this_comp->ts.u.cl->length + && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT + && actual->expr->expr_type == EXPR_CONSTANT) + { + ptrdiff_t c, e; + c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer); + e = actual->expr->value.character.length; + + if (c != e) + { + ptrdiff_t i, to; + gfc_char_t *dest; + dest = gfc_get_wide_string (c + 1); + + to = e < c ? e : c; + for (i = 0; i < to; i++) + dest[i] = actual->expr->value.character.string[i]; + + for (i = e; i < c; i++) + dest[i] = ' '; + + dest[c] = '\0'; + free (actual->expr->value.character.string); + + actual->expr->value.character.length = c; + actual->expr->value.character.string = dest; + } + } + comp_tail->val = actual->expr; if (actual->expr != NULL) comp_tail->where = actual->expr->where; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 01e2c38952c..fee5b1becf5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8637,15 +8637,24 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!sym->ts.u.cl) sym->ts.u.cl = target->ts.u.cl; - if (!sym->ts.u.cl->length && !sym->ts.deferred) + if (!sym->ts.u.cl->length + && !sym->ts.deferred + && target->expr_type == EXPR_CONSTANT) { - if (target->expr_type == EXPR_CONSTANT) - sym->ts.u.cl->length = - gfc_get_int_expr (gfc_charlen_int_kind, NULL, - target->value.character.length); - else - gfc_error ("Not Implemented: Associate target with type character" - " and non-constant length at %L", &target->where); + sym->ts.u.cl->length = + gfc_get_int_expr (gfc_charlen_int_kind, NULL, + target->value.character.length); + } + else if ((!sym->ts.u.cl->length + || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) + && target->expr_type != EXPR_VARIABLE) + { + sym->ts.u.cl = gfc_get_charlen(); + sym->ts.deferred = 1; + + /* This is reset in trans-stmt.c after the assignment + of the target expression to the associate name. */ + sym->attr.allocatable = 1; } } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4ffda26ca7d..e321db35ac2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7341,7 +7341,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else { /* Otherwise make a new one. */ - parmtype = gfc_get_element_type (TREE_TYPE (desc)); + if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + parmtype = gfc_typenode_for_spec (&expr->ts); + else + parmtype = gfc_get_element_type (TREE_TYPE (desc)); + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); @@ -9470,29 +9474,32 @@ bool gfc_is_reallocatable_lhs (gfc_expr *expr) { gfc_ref * ref; + gfc_symbol *sym; if (!expr->ref) return false; + sym = expr->symtree->n.sym; + /* An allocatable class variable with no reference. */ - if (expr->symtree->n.sym->ts.type == BT_CLASS - && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable && expr->ref && expr->ref->type == REF_COMPONENT && strcmp (expr->ref->u.c.component->name, "_data") == 0 && expr->ref->next == NULL) return true; /* An allocatable variable. */ - if (expr->symtree->n.sym->attr.allocatable + if (sym->attr.allocatable && expr->ref && expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL) return true; /* All that can be left are allocatable components. */ - if ((expr->symtree->n.sym->ts.type != BT_DERIVED - && expr->symtree->n.sym->ts.type != BT_CLASS) - || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) + if ((sym->ts.type != BT_DERIVED + && sym->ts.type != BT_CLASS) + || !sym->ts.u.derived->attr.alloc_comp) return false; /* Find a component ref followed by an array reference. */ diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 07950dc1ba9..6b4e0de430d 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -133,7 +133,7 @@ gfc_build_localized_cstring_const (const char *msgid) /* Return a string constant with the given length. Used for static - initializers. The constant will be padded or truncated to match + initializers. The constant will be padded or truncated to match length. */ tree @@ -303,7 +303,7 @@ gfc_conv_constant_to_tree (gfc_expr * expr) /* If it is has a prescribed memory representation, we build a string constant and VIEW_CONVERT to its type. */ - + switch (expr->ts.type) { case BT_INTEGER: @@ -389,12 +389,12 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr) if (expr->ts.type == BT_DERIVED && expr->ts.u.derived && expr->ts.u.derived->attr.is_iso_c) { - if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR - || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) - { - /* Create a new EXPR_CONSTANT expression for our local uses. */ - expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - } + if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) + { + /* Create a new EXPR_CONSTANT expression for our local uses. */ + expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + } } if (expr->expr_type != EXPR_CONSTANT) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4fc07b61c68..6742d2e16b0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -609,10 +609,12 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) function scope. */ if (current_function_decl != NULL_TREE) { - if (sym->ns->proc_name->backend_decl == current_function_decl - || sym->result == sym) + if (sym->ns->proc_name + && (sym->ns->proc_name->backend_decl == current_function_decl + || sym->result == sym)) gfc_add_decl_to_function (decl); - else if (sym->ns->proc_name->attr.flavor == FL_LABEL) + else if (sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_LABEL) /* This is a BLOCK construct. */ add_decl_as_local (decl); else @@ -704,7 +706,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) } /* Keep variables larger than max-stack-var-size off stack. */ - if (!sym->ns->proc_name->attr.recursive && !sym->attr.automatic + if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive) + && !sym->attr.automatic && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) /* Put variable length auto array pointers always into stack. */ @@ -1707,12 +1710,13 @@ gfc_get_symbol_decl (gfc_symbol * sym) && sym->assoc && sym->assoc->target && ((sym->assoc->target->expr_type == EXPR_VARIABLE && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) - || sym->assoc->target->expr_type == EXPR_FUNCTION)) + || sym->assoc->target->expr_type != EXPR_VARIABLE)) sym->ts.u.cl->backend_decl = NULL_TREE; if (sym->attr.associate_var && sym->ts.u.cl->backend_decl - && VAR_P (sym->ts.u.cl->backend_decl)) + && (VAR_P (sym->ts.u.cl->backend_decl) + || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)) length = gfc_index_zero_node; else length = gfc_create_string_length (sym); @@ -3498,39 +3502,41 @@ gfc_build_intrinsic_function_decls (void) void gfc_build_builtin_function_decls (void) { - tree gfc_int4_type_node = gfc_get_int_type (4); + tree gfc_int8_type_node = gfc_get_int_type (8); gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( get_identifier (PREFIX("stop_numeric")), - void_type_node, 1, gfc_int4_type_node); + void_type_node, 2, integer_type_node, boolean_type_node); /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("stop_string")), ".R.", - void_type_node, 2, pchar_type_node, gfc_int4_type_node); + void_type_node, 3, pchar_type_node, size_type_node, + boolean_type_node); /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( get_identifier (PREFIX("error_stop_numeric")), - void_type_node, 1, gfc_int4_type_node); + void_type_node, 2, integer_type_node, boolean_type_node); /* ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("error_stop_string")), ".R.", - void_type_node, 2, pchar_type_node, gfc_int4_type_node); + void_type_node, 3, pchar_type_node, size_type_node, + boolean_type_node); /* ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( get_identifier (PREFIX("pause_numeric")), - void_type_node, 1, gfc_int4_type_node); + void_type_node, 1, gfc_int8_type_node); gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("pause_string")), ".R.", - void_type_node, 2, pchar_type_node, gfc_int4_type_node); + void_type_node, 2, pchar_type_node, size_type_node); gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("runtime_error")), ".R", @@ -3635,12 +3641,12 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7, size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5, ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, - integer_type_node); + size_type_node); gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10, @@ -3662,59 +3668,60 @@ gfc_build_builtin_function_decls (void) integer_type_node, boolean_type_node, integer_type_node); gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRW", void_type_node, - 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, - integer_type_node, integer_type_node, boolean_type_node, - boolean_type_node, pint_type); + get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node, + 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRW", void_type_node, - 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, - integer_type_node, integer_type_node, boolean_type_node, - boolean_type_node, pint_type); + get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR", + void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); gfor_fndecl_caf_sendget_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWW", - void_type_node, 11, pvoid_type_node, integer_type_node, + get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR", + void_type_node, 13, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pint_type); + boolean_type_node, pint_type, pint_type, integer_type_node, + integer_type_node); gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node, - 3, pint_type, pchar_type_node, integer_type_node); + 3, pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node, - 3, pint_type, pchar_type_node, integer_type_node); + 3, pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node, 5, integer_type_node, pint_type, pint_type, - pchar_type_node, integer_type_node); + pchar_type_node, size_type_node); gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_error_stop")), - void_type_node, 1, gfc_int4_type_node); + void_type_node, 1, integer_type_node); /* CAF's ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_error_stop_str")), ".R.", - void_type_node, 2, pchar_type_node, gfc_int4_type_node); + void_type_node, 2, pchar_type_node, size_type_node); /* CAF's ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_stop_numeric")), ".R.", - void_type_node, 1, gfc_int4_type_node); + void_type_node, 1, integer_type_node); /* CAF's STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1; gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_stop_str")), ".R.", - void_type_node, 2, pchar_type_node, gfc_int4_type_node); + void_type_node, 2, pchar_type_node, size_type_node); /* CAF's STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1; @@ -3743,22 +3750,22 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_lock")), "R..WWW", void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pint_type, pchar_type_node, integer_type_node); + pint_type, pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_unlock")), "R..WW", void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_event_post")), "R..WW", void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_event_wait")), "R..WW", void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_event_query")), "R..WW", @@ -3822,17 +3829,17 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_broadcast")), "W.WW", void_type_node, 5, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_max")), "W.WW", void_type_node, 6, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node, integer_type_node); + pint_type, pchar_type_node, integer_type_node, size_type_node); gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_min")), "W.WW", void_type_node, 6, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node, integer_type_node); + pint_type, pchar_type_node, integer_type_node, size_type_node); gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_reduce")), "W.R.WW", @@ -3840,12 +3847,12 @@ gfc_build_builtin_function_decls (void) build_pointer_type (build_varargs_function_type_list (void_type_node, NULL_TREE)), integer_type_node, integer_type_node, pint_type, pchar_type_node, - integer_type_node, integer_type_node); + integer_type_node, size_type_node); gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_sum")), "W.WW", void_type_node, 5, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node); + pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_is_present")), "RRR", @@ -5348,7 +5355,7 @@ generate_coarray_sym_init (gfc_symbol *sym) token, gfc_build_addr_expr (pvoid_type_node, desc), null_pointer_node, /* stat. */ null_pointer_node, /* errgmsg. */ - integer_zero_node); /* errmsg_len. */ + build_zero_cst (size_type_node)); /* errmsg_len. */ gfc_add_expr_to_block (&caf_init_block, tmp); gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), gfc_conv_descriptor_data_get (desc))); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a4185820531..a93257c73bf 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -657,7 +657,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, } /* Array references with vector subscripts and non-variable expressions - need be coverted to a one-based descriptor. */ + need be converted to a one-based descriptor. */ if (ref || e->expr_type != EXPR_VARIABLE) { for (dim = 0; dim < e->rank; ++dim) @@ -6868,6 +6868,8 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, /* The derived symbol has already been converted to a (void *). Use its kind. */ + if (derived->ts.kind == 0) + derived->ts.kind = gfc_default_integer_kind; expr = gfc_get_int_expr (derived->ts.kind, NULL, 0); expr->ts.f90_type = derived->ts.f90_type; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 337227d3c08..c4a3775d858 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1709,12 +1709,13 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, gfc_add_expr_to_block (&se->pre, tmp); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref, - 9, token, image_index, dst_var, + 10, token, image_index, dst_var, caf_reference, lhs_kind, kind, may_require_tmp, may_realloc ? boolean_true_node : boolean_false_node, - stat); + stat, build_int_cst (integer_type_node, + array_expr->ts.type)); gfc_add_expr_to_block (&se->pre, tmp); @@ -2100,9 +2101,11 @@ conv_caf_send (gfc_code *code) { : boolean_false_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_by_ref, - 9, token, image_index, rhs_se.expr, + 10, token, image_index, rhs_se.expr, reference, lhs_kind, rhs_kind, - may_require_tmp, dst_realloc, src_stat); + may_require_tmp, dst_realloc, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type)); } else tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, @@ -2147,11 +2150,15 @@ conv_caf_send (gfc_code *code) { lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr); tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sendget_by_ref, 11, + gfor_fndecl_caf_sendget_by_ref, 13, token, image_index, lhs_reference, rhs_token, rhs_image_index, rhs_reference, lhs_kind, rhs_kind, may_require_tmp, - dst_stat, src_stat); + dst_stat, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type), + build_int_cst (integer_type_node, + rhs_expr->ts.type)); } else { @@ -9817,12 +9824,12 @@ conv_co_collective (gfc_code *code) gfc_add_block_to_block (&block, &argse.pre); gfc_add_block_to_block (&post_block, &argse.post); errmsg = argse.expr; - errmsg_len = fold_convert (integer_type_node, argse.string_length); + errmsg_len = fold_convert (size_type_node, argse.string_length); } else { errmsg = null_pointer_node; - errmsg_len = integer_zero_node; + errmsg_len = build_zero_cst (size_type_node); } /* Generate the function call. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 021c788ba54..9058712c695 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -639,12 +639,12 @@ set_parameter_value_inquire (stmtblock_t *block, tree var, /* Don't evaluate the UNIT number multiple times. */ se.expr = gfc_evaluate_now (se.expr, &se.pre); - /* UNIT numbers should be greater than zero. */ + /* UNIT numbers should be greater than the min. */ i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); cond1 = build2_loc (input_location, LT_EXPR, logical_type_node, se.expr, - fold_convert (TREE_TYPE (se.expr), - integer_zero_node)); + fold_convert (TREE_TYPE (se.expr), val)); /* UNIT numbers should be less than the max. */ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); cond2 = build2_loc (input_location, GT_EXPR, logical_type_node, @@ -2289,6 +2289,16 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, ts->kind = gfc_index_integer_kind; } + /* gfortran reaches here for "print *, c_loc(xxx)". */ + if (ts->type == BT_VOID + && code->expr1 && code->expr1->ts.type == BT_VOID + && code->expr1->symtree + && strcmp (code->expr1->symtree->name, "c_loc") == 0) + { + ts->type = BT_INTEGER; + ts->kind = gfc_index_integer_kind; + } + kind = ts->kind; function = NULL; arg2 = NULL; diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 4f5c3855799..795175d701a 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1949,9 +1949,32 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } else { - tree type = gfc_typenode_for_spec (&n->sym->ts); - OMP_CLAUSE_LINEAR_STEP (node) - = fold_convert (type, last_step); + if (kind == OMP_CLAUSE_LINEAR_REF) + { + tree type; + if (n->sym->attr.flavor == FL_PROCEDURE) + { + type = gfc_get_function_type (n->sym); + type = build_pointer_type (type); + } + else + type = gfc_sym_type (n->sym); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + /* Otherwise to be determined what exactly + should be done. */ + tree t = fold_convert (sizetype, last_step); + t = size_binop (MULT_EXPR, t, + TYPE_SIZE_UNIT (type)); + OMP_CLAUSE_LINEAR_STEP (node) = t; + } + else + { + tree type + = gfc_typenode_for_spec (&n->sym->ts); + OMP_CLAUSE_LINEAR_STEP (node) + = fold_convert (type, last_step); + } } if (n->sym->attr.dimension || n->sym->attr.allocatable) OMP_CLAUSE_LINEAR_ARRAY (node) = 1; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 573fd4818d4..cf76fd0162b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -578,7 +578,7 @@ gfc_trans_return (gfc_code * code) tree gfc_trans_pause (gfc_code * code) { - tree gfc_int4_type_node = gfc_get_int_type (4); + tree gfc_int8_type_node = gfc_get_int_type (8); gfc_se se; tree tmp; @@ -589,7 +589,7 @@ gfc_trans_pause (gfc_code * code) if (code->expr1 == NULL) { - tmp = build_int_cst (gfc_int4_type_node, 0); + tmp = build_int_cst (size_type_node, 0); tmp = build_call_expr_loc (input_location, gfor_fndecl_pause_string, 2, build_int_cst (pchar_type_node, 0), tmp); @@ -599,14 +599,15 @@ gfc_trans_pause (gfc_code * code) gfc_conv_expr (&se, code->expr1); tmp = build_call_expr_loc (input_location, gfor_fndecl_pause_numeric, 1, - fold_convert (gfc_int4_type_node, se.expr)); + fold_convert (gfc_int8_type_node, se.expr)); } else { gfc_conv_expr_reference (&se, code->expr1); tmp = build_call_expr_loc (input_location, gfor_fndecl_pause_string, 2, - se.expr, se.string_length); + se.expr, fold_convert (size_type_node, + se.string_length)); } gfc_add_expr_to_block (&se.pre, tmp); @@ -623,7 +624,6 @@ gfc_trans_pause (gfc_code * code) tree gfc_trans_stop (gfc_code *code, bool error_stop) { - tree gfc_int4_type_node = gfc_get_int_type (4); gfc_se se; tree tmp; @@ -633,7 +633,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) if (code->expr1 == NULL) { - tmp = build_int_cst (gfc_int4_type_node, 0); + tmp = build_int_cst (size_type_node, 0); tmp = build_call_expr_loc (input_location, error_stop ? (flag_coarray == GFC_FCOARRAY_LIB @@ -642,7 +642,8 @@ gfc_trans_stop (gfc_code *code, bool error_stop) : (flag_coarray == GFC_FCOARRAY_LIB ? gfor_fndecl_caf_stop_str : gfor_fndecl_stop_string), - 2, build_int_cst (pchar_type_node, 0), tmp); + 3, build_int_cst (pchar_type_node, 0), tmp, + boolean_false_node); } else if (code->expr1->ts.type == BT_INTEGER) { @@ -654,8 +655,9 @@ gfc_trans_stop (gfc_code *code, bool error_stop) : gfor_fndecl_error_stop_numeric) : (flag_coarray == GFC_FCOARRAY_LIB ? gfor_fndecl_caf_stop_numeric - : gfor_fndecl_stop_numeric), 1, - fold_convert (gfc_int4_type_node, se.expr)); + : gfor_fndecl_stop_numeric), 2, + fold_convert (integer_type_node, se.expr), + boolean_false_node); } else { @@ -668,7 +670,9 @@ gfc_trans_stop (gfc_code *code, bool error_stop) : (flag_coarray == GFC_FCOARRAY_LIB ? gfor_fndecl_caf_stop_str : gfor_fndecl_stop_string), - 2, se.expr, se.string_length); + 3, se.expr, fold_convert (size_type_node, + se.string_length), + boolean_false_node); } gfc_add_expr_to_block (&se.pre, tmp); @@ -913,12 +917,12 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) gfc_conv_expr (&argse, code->expr3); gfc_add_block_to_block (&se.pre, &argse.pre); errmsg = argse.expr; - errmsg_len = fold_convert (integer_type_node, argse.string_length); + errmsg_len = fold_convert (size_type_node, argse.string_length); } else { errmsg = null_pointer_node; - errmsg_len = integer_zero_node; + errmsg_len = build_zero_cst (size_type_node); } if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) @@ -1112,12 +1116,12 @@ gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op) gfc_conv_expr (&argse, code->expr3); gfc_add_block_to_block (&se.pre, &argse.pre); errmsg = argse.expr; - errmsg_len = fold_convert (integer_type_node, argse.string_length); + errmsg_len = fold_convert (size_type_node, argse.string_length); } else { errmsg = null_pointer_node; - errmsg_len = integer_zero_node; + errmsg_len = build_zero_cst (size_type_node); } if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) @@ -1196,12 +1200,12 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) gfc_conv_expr (&argse, code->expr3); gfc_conv_string_parameter (&argse); errmsg = gfc_build_addr_expr (NULL, argse.expr); - errmsglen = argse.string_length; + errmsglen = fold_convert (size_type_node, argse.string_length); } else if (flag_coarray == GFC_FCOARRAY_LIB) { errmsg = null_pointer_node; - errmsglen = build_int_cst (integer_type_node, 0); + errmsglen = build_int_cst (size_type_node, 0); } /* Check SYNC IMAGES(imageset) for valid image index. @@ -1926,9 +1930,26 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) { gfc_expr *lhs; tree res; + gfc_se se; + + gfc_init_se (&se, NULL); + + /* resolve.c converts some associate names to allocatable so that + allocation can take place automatically in gfc_trans_assignment. + The frontend prevents them from being either allocated, + deallocated or reallocated. */ + if (sym->attr.allocatable) + { + tmp = sym->backend_decl; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } lhs = gfc_lval_expr_from_sym (sym); res = gfc_trans_assignment (lhs, e, false, true); + gfc_add_expr_to_block (&se.pre, res); tmp = sym->backend_decl; if (e->expr_type == EXPR_FUNCTION @@ -1948,8 +1969,25 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived, tmp, 0); } + else if (sym->attr.allocatable) + { + tmp = sym->backend_decl; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + + /* A simple call to free suffices here. */ + tmp = gfc_call_free (tmp); + + /* Make sure that reallocation on assignment cannot occur. */ + sym->attr.allocatable = 0; + } + else + tmp = NULL_TREE; + res = gfc_finish_block (&se.pre); gfc_add_init_cleanup (block, res, tmp); + gfc_free_expr (lhs); } /* Set the stringlength, when needed. */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 697b7354e1b..20de203e607 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2251,6 +2251,7 @@ gfc_sym_type (gfc_symbol * sym) if (sym->attr.result && sym->ts.type == BT_CHARACTER && sym->ts.u.cl->backend_decl == NULL_TREE + && sym->ns->proc_name && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE) sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl; |