diff options
Diffstat (limited to 'gcc/fortran')
41 files changed, 2707 insertions, 965 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index de9c781ad3c..0762a6446f3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,334 @@ +2008-05-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/35756 + PR fortran/35759 + * trans-stmt.c (gfc_trans_where): Tighten up the dependency + check for calling gfc_trans_where_3. + + PR fortran/35743 + * trans-stmt.c (gfc_trans_where_2): Set the mask size to zero + if it is calculated to be negative. + + PR fortran/35745 + * trans-stmt.c (gfc_trans_where_3, gfc_trans_where_assign): Set + ss->where for scalar right hand sides. + * trans-array.c (gfc_add_loop_ss_code): If ss->where is set do + not evaluate scalars outside the loop. Clean up whitespace. + * trans.h : Add a bitfield 'where' to gfc_ss. + +2008-05-16 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h: Increase GFC_MAX_DIMENSIONS to 15. + * array.c (gfc_match_array_spec): Error with -std=f2003 if rank > 7. + +2008-04-16 Daniel Kraft <d@domob.eu> + + PR fortran/27997 + * gfortran.h: Added field "length_from_typespec" to gfc_charlength. + * aray.c (gfc_match_array_constructor): Added code to parse typespec. + (check_element_type, check_constructor_type, gfc_check_constructor_type): + Extended to support explicit typespec on constructor. + (gfc_resolve_character_array_constructor): Pad strings correctly for + explicit, constant character length. + * trans-array.c: New static global variable "typespec_chararray_ctor" + (gfc_trans_array_constructor): New code to support explicit but dynamic + character lengths. + +2008-05-16 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/34325 + * decl.c (match_attr_spec): Check for matching pairs of parenthesis. + * expr.c (gfc_specification_expr): Supplement the error message with the + type that was found. + * resolve.c (gfc_resolve_index): Likewise. + * match.c (gfc_match_parens): Clarify error message with "at or before". + (gfc_match_do): Check for matching pairs of parenthesis. + +2008-05-16 Tobias Burnus <burnus@net-b.de + + * intrinsic.texi: Write Fortran 77/90/95 instead of F77/90/95; + add missing KIND argument to ACHAR and NINT; and state that + the KIND argument is a F2003 extension for ACHAR, COUNT, IACHAR, + ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND, VERIFY. + +2008-05-16 Daniel Kraft <d@domob.eu> + + * primary.c: New private structure "gfc_structure_ctor_component". + (gfc_free_structure_ctor_component): New helper function. + (gfc_match_structure_constructor): Extended largely to support named + arguments and default initialization for structure constructors. + +2008-05-15 Steven G. Kargl <kargls@comcast.net> + + * simplify.c (gfc_simplify_dble, gfc_simplify_float, + simplify_bound, gfc_simplify_nearest, gfc_simplify_real): Plug + possible memory leaks. + (gfc_simplify_reshape): Plug possible memory leaks and dereferencing + of NULL pointers. + +2008-05-15 Steven G. Kargl <kargls@comcast.net> + + PR fortran/36239 + * simplify.c (gfc_simplify_int, gfc_simplify_intconv): Replaced hand + rolled integer conversion with gfc_int2int, gfc_real2int, and + gfc_complex2int. + (gfc_simplify_intconv): Renamed to simplify_intconv. + +2008-05-15 Steven G. Kargl, <kargl@comcast.net> + * gfortran.dg/and_or_xor.f90: New test + + * fortran/simplify.c (gfc_simplify_and, gfc_simplify_or, + gfc_simplify_xor): Don't range check logical results. + +2008-05-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-expr.c (gfc_conv_concat_op): Take care of nondefault + character kinds. + (gfc_build_compare_string): Add kind argument and use it. + (gfc_conv_statement_function): Fix indentation. + * gfortran.h (gfc_character_info): New structure. + (gfc_character_kinds): New array. + * trans-types.c (gfc_character_kinds, gfc_character_types, + gfc_pcharacter_types): New array. + (gfc_init_kinds): Fill character kinds array. + (validate_character): Take care of nondefault character kinds. + (gfc_build_uint_type): New function. + (gfc_init_types): Take care of nondefault character kinds. + (gfc_get_char_type, gfc_get_pchar_type): New functions. + (gfc_get_character_type_len): Use gfc_get_char_type. + * trans.h (gfc_build_compare_string): Adjust prototype. + (gfor_fndecl_compare_string_char4, gfor_fndecl_concat_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4): New + prototypes. + * trans-types.h (gfc_get_char_type, gfc_get_pchar_type): New + prototypes. + * trans-decl.c (gfor_fndecl_compare_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4, + gfor_fndecl_concat_string_char4): New function decls. + (gfc_build_intrinsic_function_decls): Define new *_char4 function + decls. + * trans-intrinsic.c (gfc_conv_intrinsic_minmax_char, + gfc_conv_intrinsic_len_trim, gfc_conv_intrinsic_ichar, + gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_trim, + gfc_conv_intrinsic_function): Deal with nondefault character kinds. + +2008-05-15 Sa Liu <saliu@de.ibm.com> + + * iso-c-binding.def: Add standard parameter to macro NAMED_INTCST. + All existing NAMED_INTCST definitions has standard GFC_STD_F2003, + c_int128_t, c_int_least128_t and c_int_fast128_t are added as + GNU extensions. + * iso-fortran-evn.def: Add standard parameter GFC_STD_F2003 + to macro NAMED_INTCST. + * symbol.c (std_for_isocbinding_symbol): New helper function to + return the standard that supports this isocbinding symbol. + (generate_isocbinding_symbol): Do not generate GNU extension symbols + if std=f2003. Add new parameter to NAMED_INTCST. + * module.c (use_iso_fortran_env_module): Add new parameter to + NAMED_INTCST and new field standard to struct intmod_sym. + * gfortran.h: Add new parameter to NAMED_INTCST. + * trans-types.c (init_c_interop_kinds): Add new parameter to + NAMED_INTCST. + * intrinsic.texi: Documented new types C_INT128_T, C_INT_LEASE128_T + and C_INT_FAST128_T. + +2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36059 + * trans-decl.c (gfc_build_dummy_array_decl): Don't repack + arrays that have the TARGET attribute. + +2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36186 + * simplify.c (only_convert_cmplx_boz): New function. + (gfc_simplify_cmplx, gfc_simplify_complex, gfc_simplify_dcmplx): + Call only_convert_cmplx_boz. + +2008-05-14 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/36233 + * interface.c (compare_actual_formal): Do not check sizes if the + actual is BT_PROCEDURE. + +2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/35682 + * trans-array.c (gfc_conv_ss_startstride): Any negative size is + the same as zero size. + (gfc_conv_loop_setup): Fix size calculation. + +2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/35685 + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Correctly + handle zero-size sections. + +2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36215 + * scanner.c (preprocessor_line): Allocate enough memory for a + wide string. + +2008-05-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36176 + * target-memory.c (gfc_target_expr_size): Correctly treat + substrings. + (gfc_target_encode_expr): Likewise. + (gfc_interpret_complex): Whitespace change. + +2008-05-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/35719 + * trans.c (gfc_call_malloc): If size equals zero, allocate one + byte; don't return a null pointer. + +2008-05-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36197 + * module.c (quote_string): Fix sprintf format. + +2008-05-09 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36162 + * module.c (quote_string, unquote_string, + mio_allocated_wide_string): New functions. + (mio_expr): Call mio_allocated_wide_string where needed. + +2008-05-07 Kenneth Zadeck <zadeck@naturalbridge.com> + + * trans-decl.c (gfc_get_extern_function_decl, build_function_decl): + Rename DECL_IS_PURE to DECL_PURE_P. + +2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * arith.c: (gfc_arith_concat, gfc_compare_string, + gfc_compare_with_Cstring, hollerith2representation, + gfc_hollerith2int, gfc_hollerith2real, gfc_hollerith2complex, + gfc_hollerith2character, gfc_hollerith2logical): Use wide + characters for character constants. + * data.c (create_character_intializer): Likewise. + * decl.c (gfc_set_constant_character_len): Likewise. + * dump-parse-tree.c (show_char_const): Correctly dump wide + character strings. + error.c (print_wide_char): Rename into gfc_print_wide_char. + (show_locus): Adapt to new prototype of gfc_print_wide_char. + expr.c (free_expr0): Representation is now disjunct from + character string value, so we always free it. + (gfc_copy_expr, find_substring_ref, gfc_simplify_expr): Adapt + to wide character strings. + * gfortran.h (gfc_expr): Make value.character.string a wide string. + (gfc_wide_toupper, gfc_wide_strncasecmp, gfc_wide_memset, + gfc_widechar_to_char, gfc_char_to_widechar): New prototypes. + (gfc_get_wide_string): New macro. + (gfc_print_wide_char): New prototype. + * io.c (format_string): Make a wide string. + (next_char, gfc_match_format, compare_to_allowed_values, + gfc_match_open): Deal with wide strings. + * module.c (mio_expr): Convert between wide strings and ASCII ones. + * primary.c (match_hollerith_constant, match_charkind_name): + Handle wide strings. + * resolve.c (build_default_init_expr): Likewise. + * scanner.c (gfc_wide_toupper, gfc_wide_memset, + gfc_char_to_widechar): New functions. + (wide_strchr, gfc_widechar_to_char, gfc_wide_strncasecmp): + Changes in prototypes. + (gfc_define_undef_line, load_line, preprocessor_line, + include_line, load_file, gfc_read_orig_filename): Handle wide + strings. + * simplify.c (gfc_simplify_achar, gfc_simplify_adjustl, + gfc_simplify_adjustr, gfc_simplify_char, gfc_simplify_iachar, + gfc_simplify_ichar, simplify_min_max, gfc_simplify_new_line, + gfc_simplify_repeat): Handle wide strings. + (wide_strspn, wide_strcspn): New helper functions. + (gfc_simplify_scan, gfc_simplify_trim, gfc_simplify_verify): + Handle wide strings. + * symbol.c (generate_isocbinding_symbol): Likewise. + * target-memory.c (size_character, gfc_target_expr_size, + encode_character, gfc_target_encode_expr, gfc_interpret_character, + gfc_target_interpret_expr): Handle wide strings. + * trans-const.c (gfc_conv_string_init): Lower wide strings to + narrow ones. + (gfc_conv_constant_to_tree): Likewise. + * trans-expr.c (gfc_conv_substring_expr): Handle wide strings. + * trans-io.c (gfc_new_nml_name_expr): Likewise. + * trans-stmt.c (gfc_trans_label_assign): Likewise. + +2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1, + gfc_simplify_bessel_jn,gfc_simplify_bessel_y0, + gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): Mark arguments + with ATTRIBUTE_UNUSED. + +2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * check.c (gfc_check_sizeof): Switch to ATTRIBUTE_UNUSED. + * simplify.c (gfc_simplify_lgamma): Likewise. + +2008-05-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * openmp.c (gfc_match_omp_eos): Use gfc_next_ascii_char and + gfc_peek_ascii_char. + * decl.c (gfc_match_kind_spec, gfc_match_type_spec, + gfc_match_implicit_none, match_implicit_range, gfc_match_implicit, + match_string_p, match_attr_spec, gfc_match_suffix, + match_procedure_decl, gfc_match_entry, gfc_match_subroutine): + Likewise. + * gfortran.h (gfc_char_t): New type. + (gfc_linebuf): Make line member a gfc_char_t. + (locus): Make nextc member a gfc_char_t. + (gfc_wide_is_printable, gfc_wide_is_digit, gfc_wide_fits_in_byte, + gfc_wide_tolower, gfc_wide_strlen, gfc_next_ascii_char, + gfc_peek_ascii_char, gfc_check_digit): New prototypes. + * error.c (print_wide_char): New function. + (show_locus): Use print_wide_char and gfc_wide_strlen. + * io.c (next_char): Use gfc_char_t type. + (match_io): Use gfc_peek_ascii_char and gfc_next_ascii_char. + * match.c (gfc_match_parens, gfc_match_eos, + gfc_match_small_literal_int, gfc_match_name, gfc_match_name_C, + gfc_match_intrinsic_op, gfc_match_char, gfc_match_return, + gfc_match_common): Likewise. + * match.h (gfc_match_special_char): Change prototype. + * parse.c (decode_specification_statement, decode_statement, + decode_omp_directive, next_free, next_fixed): Use + gfc_peek_ascii_char and gfc_next_ascii_char. + * primary.c (gfc_check_digit): Change name. + (match_digits, match_hollerith_constant, match_boz_constant, + match_real_constant, next_string_char, match_charkind_name, + match_string_constant, match_logical_constant_string, + match_complex_constant, match_actual_arg, match_varspec, + gfc_match_rvalue, match_variable): Use gfc_peek_ascii_char and + gfc_next_ascii_char. + * scanner.c (gfc_wide_fits_in_byte, wide_is_ascii, + gfc_wide_is_printable, gfc_wide_tolower, gfc_wide_is_digit, + gfc_wide_is_digit, wide_atoi, gfc_wide_strlen, wide_strcpy, + wide_strchr, widechar_to_char, wide_strncmp, wide_strncasecmp, + gfc_next_ascii_char, gfc_peek_ascii_char): + New functions. + (next_char, gfc_define_undef_line, skip_free_comments, + gfc_next_char_literal, gfc_next_char, gfc_peek_char, + gfc_error_recovery, load_line, preprocessor_line, include_line, + load_file, gfc_read_orig_filename): Use gfc_char_t for source + characters and the {gfc_,}wide_* functions to manipulate wide + strings. + +2008-05-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/36117 + * intrinsic.c (add_functions): Call gfc_simplify_bessel_*. + * intrinsic.h: Add prototypes for gfc_simplify_bessel_*. + * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1, + gfc_simplify_bessel_jn,gfc_simplify_bessel_y0, + gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): New. + 2008-05-03 Janus Weil <jaydub66@gmail.com> * misc.c (gfc_clear_ts): Set interface to NULL. @@ -673,7 +1004,7 @@ gfc_conv_allocated, gfc_conv_associated, gfc_conv_intrinsic_trim, gfc_conv_intrinsic_repeat): Likewise. -2008-02-23 Francois-Xavier Coudert <coudert@clipper.ens.fr> +2008-02-23 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> PR target/25477 * trans-expr.c (gfc_conv_power_op): Use BUILT_IN_CPOW{F,,L}. diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 4b8d45b189b..cbfcf291049 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1102,14 +1102,15 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) len = op1->value.character.length + op2->value.character.length; - result->value.character.string = gfc_getmem (len + 1); + result->value.character.string = gfc_get_wide_string (len + 1); result->value.character.length = len; memcpy (result->value.character.string, op1->value.character.string, - op1->value.character.length); + op1->value.character.length * sizeof (gfc_char_t)); - memcpy (result->value.character.string + op1->value.character.length, - op2->value.character.string, op2->value.character.length); + memcpy (&result->value.character.string[op1->value.character.length], + op2->value.character.string, + op2->value.character.length * sizeof (gfc_char_t)); result->value.character.string[len] = '\0'; @@ -1203,7 +1204,8 @@ compare_complex (gfc_expr *op1, gfc_expr *op2) int gfc_compare_string (gfc_expr *a, gfc_expr *b) { - int len, alen, blen, i, ac, bc; + int len, alen, blen, i; + gfc_char_t ac, bc; alen = a->value.character.length; blen = b->value.character.length; @@ -1212,10 +1214,8 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b) for (i = 0; i < len; i++) { - /* We cast to unsigned char because default char, if it is signed, - would lead to ac < 0 for string[i] > 127. */ - ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' '); - bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' '); + ac = ((i < alen) ? a->value.character.string[i] : ' '); + bc = ((i < blen) ? b->value.character.string[i] : ' '); if (ac < bc) return -1; @@ -1231,7 +1231,8 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b) int gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) { - int len, alen, blen, i, ac, bc; + int len, alen, blen, i; + gfc_char_t ac, bc; alen = a->value.character.length; blen = strlen (b); @@ -1240,10 +1241,8 @@ gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) for (i = 0; i < len; i++) { - /* We cast to unsigned char because default char, if it is signed, - would lead to ac < 0 for string[i] > 127. */ - ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' '); - bc = (unsigned char) ((i < blen) ? b[i] : ' '); + ac = ((i < alen) ? a->value.character.string[i] : ' '); + bc = ((i < blen) ? b[i] : ' '); if (!case_sensitive) { @@ -2438,7 +2437,7 @@ hollerith2representation (gfc_expr *result, gfc_expr *src) result->representation.string = gfc_getmem (result_len + 1); memcpy (result->representation.string, src->representation.string, - MIN (result_len, src_len)); + MIN (result_len, src_len)); if (src_len < result_len) memset (&result->representation.string[src_len], ' ', result_len - src_len); @@ -2462,8 +2461,8 @@ gfc_hollerith2int (gfc_expr *src, int kind) result->where = src->where; hollerith2representation (result, src); - gfc_interpret_integer(kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.integer); + gfc_interpret_integer (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.integer); return result; } @@ -2486,8 +2485,8 @@ gfc_hollerith2real (gfc_expr *src, int kind) result->where = src->where; hollerith2representation (result, src); - gfc_interpret_float(kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.real); + gfc_interpret_float (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.real); return result; } @@ -2510,9 +2509,9 @@ gfc_hollerith2complex (gfc_expr *src, int kind) result->where = src->where; hollerith2representation (result, src); - gfc_interpret_complex(kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.complex.r, - result->value.complex.i); + gfc_interpret_complex (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.complex.r, + result->value.complex.i); return result; } @@ -2529,8 +2528,9 @@ gfc_hollerith2character (gfc_expr *src, int kind) result->ts.type = BT_CHARACTER; result->ts.kind = kind; - result->value.character.string = result->representation.string; result->value.character.length = result->representation.length; + result->value.character.string + = gfc_char_to_widechar (result->representation.string); return result; } @@ -2553,8 +2553,8 @@ gfc_hollerith2logical (gfc_expr *src, int kind) result->where = src->where; hollerith2representation (result, src); - gfc_interpret_logical(kind, (unsigned char *) result->representation.string, - result->representation.length, &result->value.logical); + gfc_interpret_logical (kind, (unsigned char *) result->representation.string, + result->representation.length, &result->value.logical); return result; } diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index adc3f3f6bfb..5593289a910 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -437,6 +437,12 @@ gfc_match_array_spec (gfc_array_spec **asp) goto cleanup; } + if (as->rank > 7 + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " + "specification at %C with more than 7 dimensions") + == FAILURE) + goto cleanup; + as->rank++; } @@ -877,9 +883,11 @@ gfc_match_array_constructor (gfc_expr **result) { gfc_constructor *head, *tail, *new; gfc_expr *expr; + gfc_typespec ts; locus where; match m; const char *end_delim; + bool seen_ts; if (gfc_match (" (/") == MATCH_NO) { @@ -898,11 +906,33 @@ gfc_match_array_constructor (gfc_expr **result) where = gfc_current_locus; head = tail = NULL; + seen_ts = false; + + /* Try to match an optional "type-spec ::" */ + if (gfc_match_type_spec (&ts, 0) == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor " + "including type specification at %C") == FAILURE) + goto cleanup; + } + } + + if (! seen_ts) + gfc_current_locus = where; if (gfc_match (end_delim) == MATCH_YES) { - gfc_error ("Empty array constructor at %C is not allowed"); - goto cleanup; + if (seen_ts) + goto done; + else + { + gfc_error ("Empty array constructor at %C is not allowed"); + goto cleanup; + } } for (;;) @@ -927,6 +957,7 @@ gfc_match_array_constructor (gfc_expr **result) if (gfc_match (end_delim) == MATCH_NO) goto syntax; +done: expr = gfc_get_expr (); expr->expr_type = EXPR_ARRAY; @@ -934,6 +965,14 @@ gfc_match_array_constructor (gfc_expr **result) expr->value.constructor = head; /* Size must be calculated at resolution time. */ + if (seen_ts) + expr->ts = ts; + else + expr->ts.type = BT_UNKNOWN; + + if (expr->ts.cl) + expr->ts.cl->length_from_typespec = seen_ts; + expr->where = where; expr->rank = 1; @@ -964,7 +1003,7 @@ static enum cons_state; static int -check_element_type (gfc_expr *expr) +check_element_type (gfc_expr *expr, bool convert) { if (cons_state == CONS_BAD) return 0; /* Suppress further errors */ @@ -985,6 +1024,9 @@ check_element_type (gfc_expr *expr) if (gfc_compare_types (&constructor_ts, &expr->ts)) return 0; + if (convert) + return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1; + gfc_error ("Element in %s array constructor at %L is %s", gfc_typename (&constructor_ts), &expr->where, gfc_typename (&expr->ts)); @@ -997,7 +1039,7 @@ check_element_type (gfc_expr *expr) /* Recursive work function for gfc_check_constructor_type(). */ static try -check_constructor_type (gfc_constructor *c) +check_constructor_type (gfc_constructor *c, bool convert) { gfc_expr *e; @@ -1007,13 +1049,13 @@ check_constructor_type (gfc_constructor *c) if (e->expr_type == EXPR_ARRAY) { - if (check_constructor_type (e->value.constructor) == FAILURE) + if (check_constructor_type (e->value.constructor, convert) == FAILURE) return FAILURE; continue; } - if (check_element_type (e)) + if (check_element_type (e, convert)) return FAILURE; } @@ -1029,10 +1071,20 @@ gfc_check_constructor_type (gfc_expr *e) { try t; - cons_state = CONS_START; - gfc_clear_ts (&constructor_ts); + if (e->ts.type != BT_UNKNOWN) + { + cons_state = CONS_GOOD; + constructor_ts = e->ts; + } + else + { + cons_state = CONS_START; + gfc_clear_ts (&constructor_ts); + } - t = check_constructor_type (e->value.constructor); + /* If e->ts.type != BT_UNKNOWN, the array constructor included a + typespec, and we will now convert the values on the fly. */ + t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); if (t == SUCCESS && e->ts.type == BT_UNKNOWN) e->ts = constructor_ts; @@ -1526,13 +1578,15 @@ resolve_array_list (gfc_constructor *p) /* Resolve character array constructor. If it is a constant character array and not specified character length, update character length to the maximum of - its element constructors' length. */ + its element constructors' length. For arrays with fixed length, pad the + elements as necessary with needed_length. */ void gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; int max_length; + bool generated_length; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); @@ -1557,6 +1611,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) got_charlen: + generated_length = false; if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable @@ -1596,12 +1651,46 @@ got_charlen: { /* Update the character length of the array constructor. */ expr->ts.cl->length = gfc_int_expr (max_length); - /* Update the element constructors. */ - for (p = expr->value.constructor; p; p = p->next) - if (p->expr->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (max_length, p->expr, true); + generated_length = true; + /* Real update follows below. */ } } + else + { + /* We've got a character length specified. It should be an integer, + otherwise an error is signalled elsewhere. */ + gcc_assert (expr->ts.cl->length); + + /* If we've got a constant character length, pad according to this. + gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets + max_length only if they pass. */ + gfc_extract_int (expr->ts.cl->length, &max_length); + } + + /* Found a length to update to, do it for all element strings shorter than + the target length. */ + if (max_length != -1) + { + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->expr_type == EXPR_CONSTANT) + { + gfc_expr *cl = NULL; + int current_length = -1; + + if (p->expr->ts.cl && p->expr->ts.cl->length) + { + cl = p->expr->ts.cl->length; + gfc_extract_int (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + if (generated_length || ! cl + || (current_length != -1 && current_length < max_length)) + gfc_set_constant_character_len (max_length, p->expr, true); + } + } } diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 5f782400dd3..f0497a1c88b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2474,7 +2474,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) try -gfc_check_sizeof (gfc_expr *arg __attribute__((unused))) +gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED) { return SUCCESS; } diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 13af445dfd4..6cc7223af2f 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -151,10 +151,8 @@ static gfc_expr * create_character_intializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { - int len; - int start; - int end; - char *dest, *rvalue_string; + int len, start, end; + gfc_char_t *dest; gfc_extract_int (ts->cl->length, &len); @@ -165,13 +163,13 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, init->expr_type = EXPR_CONSTANT; init->ts = *ts; - dest = gfc_getmem (len + 1); + dest = gfc_get_wide_string (len + 1); dest[len] = '\0'; init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ if (ref != NULL) - memset (dest, ' ', len); + gfc_wide_memset (dest, ' ', len); } else dest = init->value.character.string; @@ -208,15 +206,9 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) - { - len = rvalue->representation.length; - rvalue_string = rvalue->representation.string; - } + len = rvalue->representation.length; else - { - len = rvalue->value.character.length; - rvalue_string = rvalue->value.character.string; - } + len = rvalue->value.character.length; if (len > end - start) { @@ -225,16 +217,26 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, "at %L", &rvalue->where); } - memcpy (&dest[start], rvalue_string, len); + if (rvalue->ts.type == BT_HOLLERITH) + { + int i; + for (i = 0; i < len; i++) + dest[start+i] = rvalue->representation.string[i]; + } + else + memcpy (&dest[start], rvalue->value.character.string, + len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) - memset (&dest[start + len], ' ', end - (start + len)); + gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) { init->representation.length = init->value.character.length; - init->representation.string = init->value.character.string; + init->representation.string + = gfc_widechar_to_char (init->value.character.string, + init->value.character.length); } return init; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index f52c2f1ec8f..5a1ce038f1f 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1089,7 +1089,7 @@ build_sym (const char *name, gfc_charlen *cl, void gfc_set_constant_character_len (int len, gfc_expr *expr, bool array) { - char *s; + gfc_char_t *s; int slen; gcc_assert (expr->expr_type == EXPR_CONSTANT); @@ -1098,10 +1098,11 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, bool array) slen = expr->value.character.length; if (len != slen) { - s = gfc_getmem (len + 1); - memcpy (s, expr->value.character.string, MIN (len, slen)); + s = gfc_get_wide_string (len + 1); + memcpy (s, expr->value.character.string, + MIN (len, slen) * sizeof (gfc_char_t)); if (len > slen) - memset (&s[slen], ' ', len - slen); + gfc_wide_memset (&s[slen], ' ', len - slen); if (gfc_option.warn_character_truncation && slen > len) gfc_warning_now ("CHARACTER expression at %L is being truncated " @@ -1940,7 +1941,8 @@ kind_expr: } gfc_gobble_whitespace (); - if ((c = gfc_next_char ()) != ')' && (ts->type != BT_CHARACTER || c != ',')) + if ((c = gfc_next_ascii_char ()) != ')' + && (ts->type != BT_CHARACTER || c != ',')) { if (ts->type == BT_CHARACTER) gfc_error ("Missing right parenthesis or comma at %C"); @@ -2213,7 +2215,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; - int c; + char c; bool seen_deferred_kind; /* A belt and braces check that the typespec is correctly being treated @@ -2360,7 +2362,7 @@ get_kind: if (gfc_current_form == FORM_FREE) { - c = gfc_peek_char(); + c = gfc_peek_ascii_char(); if (!gfc_is_whitespace(c) && c != '*' && c != '(' && c != ':' && c != ',') return MATCH_NO; @@ -2400,13 +2402,14 @@ gfc_match_implicit_none (void) static match match_implicit_range (void) { - int c, c1, c2, inner; + char c, c1, c2; + int inner; locus cur_loc; cur_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (c != '(') { gfc_error ("Missing character range in IMPLICIT at %C"); @@ -2417,12 +2420,12 @@ match_implicit_range (void) while (inner) { gfc_gobble_whitespace (); - c1 = gfc_next_char (); + c1 = gfc_next_ascii_char (); if (!ISALPHA (c1)) goto bad; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); switch (c) { @@ -2435,12 +2438,12 @@ match_implicit_range (void) case '-': gfc_gobble_whitespace (); - c2 = gfc_next_char (); + c2 = gfc_next_ascii_char (); if (!ISALPHA (c2)) goto bad; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if ((c != ',') && (c != ')')) goto bad; @@ -2503,7 +2506,7 @@ gfc_match_implicit (void) { gfc_typespec ts; locus cur_loc; - int c; + char c; match m; gfc_clear_ts (&ts); @@ -2534,7 +2537,7 @@ gfc_match_implicit (void) { /* We may have <TYPE> (<RANGE>). */ gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if ((c == '\n') || (c == ',')) { /* Check for CHARACTER with no length parameter. */ @@ -2584,7 +2587,7 @@ gfc_match_implicit (void) goto syntax; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if ((c != '\n') && (c != ',')) goto syntax; @@ -2713,7 +2716,7 @@ match_string_p (const char *target) const char *p; for (p = target; *p; p++) - if (gfc_next_char () != *p) + if ((char) gfc_next_ascii_char () != *p) return false; return true; } @@ -2765,22 +2768,22 @@ match_attr_spec (void) for (;;) { - int ch; + char ch; d = DECL_NONE; gfc_gobble_whitespace (); - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == ':') { /* This is the successful exit condition for the loop. */ - if (gfc_next_char () == ':') + if (gfc_next_ascii_char () == ':') break; } else if (ch == ',') { gfc_gobble_whitespace (); - switch (gfc_peek_char ()) + switch (gfc_peek_ascii_char ()) { case 'a': if (match_string_p ("allocatable")) @@ -2809,7 +2812,7 @@ match_attr_spec (void) case 'i': if (match_string_p ("int")) { - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == 'e') { if (match_string_p ("nt")) @@ -2841,8 +2844,8 @@ match_attr_spec (void) break; case 'p': - gfc_next_char (); - switch (gfc_next_char ()) + gfc_next_ascii_char (); + switch (gfc_next_ascii_char ()) { case 'a': if (match_string_p ("rameter")) @@ -2861,7 +2864,7 @@ match_attr_spec (void) break; case 'r': - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == 'i') { if (match_string_p ("vate")) @@ -2901,8 +2904,8 @@ match_attr_spec (void) break; case 'v': - gfc_next_char (); - ch = gfc_next_char (); + gfc_next_ascii_char (); + ch = gfc_next_ascii_char (); if (ch == 'a') { if (match_string_p ("lue")) @@ -2931,6 +2934,13 @@ match_attr_spec (void) goto cleanup; } + /* Check to make sure any parens are paired up correctly. */ + if (gfc_match_parens () == MATCH_ERROR) + { + m = MATCH_ERROR; + goto cleanup; + } + seen[d]++; seen_at[d] = gfc_current_locus; @@ -3938,7 +3948,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) match is_bind_c; /* Found bind(c). */ match is_result; /* Found result clause. */ match found_match; /* Status of whether we've found a good match. */ - int peek_char; /* Character we're going to peek at. */ + char peek_char; /* Character we're going to peek at. */ bool allow_binding_name; /* Initialize to having found nothing. */ @@ -3948,7 +3958,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) /* Get the next char to narrow between result and bind(c). */ gfc_gobble_whitespace (); - peek_char = gfc_peek_char (); + peek_char = gfc_peek_ascii_char (); /* C binding names are not allowed for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS @@ -4037,7 +4047,7 @@ match_procedure_decl (void) /* Get the type spec. for the procedure interface. */ old_loc = gfc_current_locus; m = gfc_match_type_spec (¤t_ts, 0); - if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')')) + if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) goto got_ts; if (m == MATCH_ERROR) @@ -4530,7 +4540,7 @@ gfc_match_entry (void) /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); - peek_char = gfc_peek_char (); + peek_char = gfc_peek_ascii_char (); if (state == COMP_SUBROUTINE) { @@ -4686,7 +4696,7 @@ gfc_match_subroutine (void) /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); - peek_char = gfc_peek_char (); + peek_char = gfc_peek_ascii_char (); if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; @@ -5486,7 +5496,7 @@ match gfc_match_pointer (void) { gfc_gobble_whitespace (); - if (gfc_peek_char () == '(') + if (gfc_peek_ascii_char () == '(') { if (!gfc_option.flag_cray_pointer) { diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index c195dcf977f..44a4941e7b4 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -301,7 +301,7 @@ show_constructor (gfc_constructor *c) static void -show_char_const (const char *c, int length) +show_char_const (const gfc_char_t *c, int length) { int i; @@ -310,10 +310,8 @@ show_char_const (const char *c, int length) { if (c[i] == '\'') fputs ("''", dumpfile); - else if (ISPRINT (c[i])) - fputc (c[i], dumpfile); else - fprintf (dumpfile, "' // ACHAR(%d) // '", c[i]); + fputs (gfc_print_wide_char (c[i]), dumpfile); } fputc ('\'', dumpfile); } diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 40eccde5adf..a9cbe9ef5f2 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -152,6 +152,70 @@ error_integer (long int i) } +static char wide_char_print_buffer[11]; + +const char * +gfc_print_wide_char (gfc_char_t c) +{ + static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', + '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; + char *buf = wide_char_print_buffer; + + if (gfc_wide_is_printable (c)) + { + buf[1] = '\0'; + buf[0] = (unsigned char) c; + } + else if (c < ((gfc_char_t) 1 << 8)) + { + buf[4] = '\0'; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = '\\'; + buf[0] = 'x'; + } + else if (c < ((gfc_char_t) 1 << 16)) + { + buf[6] = '\0'; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = '\\'; + buf[0] = 'u'; + } + else + { + buf[10] = '\0'; + buf[9] = xdigit[c & 0x0F]; + c = c >> 4; + buf[8] = xdigit[c & 0x0F]; + c = c >> 4; + buf[7] = xdigit[c & 0x0F]; + c = c >> 4; + buf[6] = xdigit[c & 0x0F]; + c = c >> 4; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = '\\'; + buf[0] = 'U'; + } + + return buf; +} + /* Show the file, where it was included, and the source line, give a locus. Calls error_printf() recursively, but the recursion is at most one level deep. */ @@ -163,8 +227,8 @@ show_locus (locus *loc, int c1, int c2) { gfc_linebuf *lb; gfc_file *f; - char c, *p; - int i, m, offset, cmax; + gfc_char_t c, *p; + int i, offset, cmax; /* TODO: Either limit the total length and number of included files displayed or add buffering of arbitrary number of characters in @@ -246,8 +310,8 @@ show_locus (locus *loc, int c1, int c2) to work correctly when nonprintable characters exist. A better solution should be found. */ - p = lb->line + offset; - i = strlen (p); + p = &(lb->line[offset]); + i = gfc_wide_strlen (p); if (i > terminal_width) i = terminal_width - 1; @@ -257,23 +321,7 @@ show_locus (locus *loc, int c1, int c2) if (c == '\t') c = ' '; - if (ISPRINT (c)) - error_char (c); - else - { - error_char ('\\'); - error_char ('x'); - - m = ((c >> 4) & 0x0F) + '0'; - if (m > '9') - m += 'A' - '9' - 1; - error_char (m); - - m = (c & 0x0F) + '0'; - if (m > '9') - m += 'A' - '9' - 1; - error_char (m); - } + error_string (gfc_print_wide_char (c)); } error_char ('\n'); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 70914c14aab..e6c1e4e9dbe 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -164,9 +164,8 @@ free_expr0 (gfc_expr *e) break; } - /* Free the representation, except in character constants where it - is the same as value.character.string and thus already freed. */ - if (e->representation.string && e->ts.type != BT_CHARACTER) + /* Free the representation. */ + if (e->representation.string) gfc_free (e->representation.string); break; @@ -393,7 +392,8 @@ gfc_expr * gfc_copy_expr (gfc_expr *p) { gfc_expr *q; - char *s; + gfc_char_t *s; + char *c; if (p == NULL) return NULL; @@ -404,20 +404,19 @@ gfc_copy_expr (gfc_expr *p) switch (q->expr_type) { case EXPR_SUBSTRING: - s = gfc_getmem (p->value.character.length + 1); + s = gfc_get_wide_string (p->value.character.length + 1); q->value.character.string = s; - - memcpy (s, p->value.character.string, p->value.character.length + 1); + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); break; case EXPR_CONSTANT: /* Copy target representation, if it exists. */ if (p->representation.string) { - s = gfc_getmem (p->representation.length + 1); - q->representation.string = s; - - memcpy (s, p->representation.string, p->representation.length + 1); + c = gfc_getmem (p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); } /* Copy the values of any pointer components of p->value. */ @@ -443,10 +442,11 @@ gfc_copy_expr (gfc_expr *p) case BT_CHARACTER: if (p->representation.string) - q->value.character.string = q->representation.string; + q->value.character.string + = gfc_char_to_widechar (q->representation.string); else { - s = gfc_getmem (p->value.character.length + 1); + s = gfc_get_wide_string (p->value.character.length + 1); q->value.character.string = s; /* This is the case for the C_NULL_CHAR named constant. */ @@ -460,7 +460,7 @@ gfc_copy_expr (gfc_expr *p) } else memcpy (s, p->value.character.string, - p->value.character.length + 1); + (p->value.character.length + 1) * sizeof (gfc_char_t)); } break; @@ -1379,7 +1379,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) int end; int start; int length; - char *chr; + gfc_char_t *chr; if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) @@ -1392,9 +1392,10 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); length = end - start + 1; - chr = (*newp)->value.character.string = gfc_getmem (length + 1); + chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); (*newp)->value.character.length = length; - memcpy (chr, &p->value.character.string[start - 1], length); + memcpy (chr, &p->value.character.string[start - 1], + length * sizeof (gfc_char_t)); chr[length] = '\0'; return SUCCESS; } @@ -1592,7 +1593,7 @@ gfc_simplify_expr (gfc_expr *p, int type) if (gfc_is_constant_expr (p)) { - char *s; + gfc_char_t *s; int start, end; if (p->ref && p->ref->u.ss.start) @@ -1608,8 +1609,9 @@ gfc_simplify_expr (gfc_expr *p, int type) else end = p->value.character.length; - s = gfc_getmem (end - start + 2); - memcpy (s, p->value.character.string + start, end - start); + s = gfc_get_wide_string (end - start + 2); + memcpy (s, p->value.character.string + start, + (end - start) * sizeof (gfc_char_t)); s[end - start + 1] = '\0'; /* TODO: C-style string. */ gfc_free (p->value.character.string); p->value.character.string = s; @@ -2571,7 +2573,8 @@ gfc_specification_expr (gfc_expr *e) if (e->ts.type != BT_INTEGER) { - gfc_error ("Expression at %L must be of INTEGER type", &e->where); + gfc_error ("Expression at %L must be of INTEGER type, found %s", + &e->where, gfc_basic_typename (e->ts.type)); return FAILURE; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f6a7c54123b..5fa3bc1f2c7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -556,7 +556,7 @@ init_local_integer; /* Used for keeping things in balanced binary trees. */ #define BBT_HEADER(self) int priority; struct self *left, *right -#define NAMED_INTCST(a,b,c) a, +#define NAMED_INTCST(a,b,c,d) a, typedef enum { ISOFORTRANENV_INVALID = -1, @@ -566,7 +566,7 @@ typedef enum iso_fortran_env_symbol; #undef NAMED_INTCST -#define NAMED_INTCST(a,b,c) a, +#define NAMED_INTCST(a,b,c,d) a, #define NAMED_REALCST(a,b,c) a, #define NAMED_CMPXCST(a,b,c) a, #define NAMED_LOGCST(a,b,c) a, @@ -700,6 +700,21 @@ typedef struct symbol_attribute; +/* We need to store source lines as sequences of multibyte source + characters. We define here a type wide enough to hold any multibyte + source character, just like libcpp does. A 32-bit type is enough. */ + +#if HOST_BITS_PER_INT >= 32 +typedef unsigned int gfc_char_t; +#elif HOST_BITS_PER_LONG >= 32 +typedef unsigned long gfc_char_t; +#elif defined(HAVE_LONG_LONG) && (HOST_BITS_PER_LONGLONG >= 32) +typedef unsigned long long gfc_char_t; +#else +# error "Cannot find an integer type with at least 32 bits" +#endif + + /* The following three structures are used to identify a location in the sources. @@ -729,7 +744,7 @@ typedef struct gfc_linebuf int truncated; bool dbg_emitted; - char line[1]; + gfc_char_t line[1]; } gfc_linebuf; #define gfc_linebuf_header_size (offsetof (gfc_linebuf, line)) @@ -738,7 +753,7 @@ typedef struct gfc_linebuf typedef struct { - char *nextc; + gfc_char_t *nextc; gfc_linebuf *lb; } locus; @@ -769,6 +784,7 @@ typedef struct gfc_charlen { struct gfc_expr *length; struct gfc_charlen *next; + bool length_from_typespec; /* Length from explicit array ctor typespec? */ tree backend_decl; int resolved; @@ -1482,7 +1498,7 @@ typedef struct gfc_expr struct { int length; - char *string; + gfc_char_t *string; } character; @@ -1552,6 +1568,15 @@ gfc_real_info; extern gfc_real_info gfc_real_kinds[]; +typedef struct +{ + int kind, bit_size; + const char *name; +} +gfc_character_info; + +extern gfc_character_info gfc_character_kinds[]; + /* Equivalence structures. Equivalent lvalues are linked along the *eq pointer, equivalence sets are strung along the *next node. */ @@ -1940,10 +1965,25 @@ void gfc_advance_line (void); int gfc_check_include (void); int gfc_define_undef_line (void); +int gfc_wide_is_printable (gfc_char_t); +int gfc_wide_is_digit (gfc_char_t); +int gfc_wide_fits_in_byte (gfc_char_t); +gfc_char_t gfc_wide_tolower (gfc_char_t); +gfc_char_t gfc_wide_toupper (gfc_char_t); +size_t gfc_wide_strlen (const gfc_char_t *); +int gfc_wide_strncasecmp (const gfc_char_t *, const char *, size_t); +gfc_char_t *gfc_wide_memset (gfc_char_t *, gfc_char_t, size_t); +char *gfc_widechar_to_char (const gfc_char_t *, int); +gfc_char_t *gfc_char_to_widechar (const char *); + +#define gfc_get_wide_string(n) gfc_getmem((n) * sizeof(gfc_char_t)) + void gfc_skip_comments (void); -int gfc_next_char_literal (int); -int gfc_next_char (void); -int gfc_peek_char (void); +gfc_char_t gfc_next_char_literal (int); +gfc_char_t gfc_next_char (void); +char gfc_next_ascii_char (void); +gfc_char_t gfc_peek_char (void); +char gfc_peek_ascii_char (void); void gfc_error_recovery (void); void gfc_gobble_whitespace (void); try gfc_new_file (void); @@ -1996,6 +2036,8 @@ typedef struct gfc_error_buf void gfc_error_init_1 (void); void gfc_buffer_error (int); +const char *gfc_print_wide_char (gfc_char_t); + void gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_warning_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_clear_warning (void); @@ -2354,6 +2396,7 @@ bool gfc_check_access (gfc_access, gfc_access); symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); symbol_attribute gfc_expr_attr (gfc_expr *); match gfc_match_rvalue (gfc_expr **); +int gfc_check_digit (char, int); /* trans.c */ void gfc_generate_code (gfc_namespace *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f5746bf0a53..f70cedba949 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1942,7 +1942,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, actual_size = get_expr_storage_size (a->expr); formal_size = get_sym_storage_size (f->sym); - if (actual_size != 0 && actual_size < formal_size) + if (actual_size != 0 + && actual_size < formal_size + && a->expr->ts.type != BT_PROCEDURE) { if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) gfc_warning ("Character length of actual argument shorter " diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 441fbecdc17..f6381275997 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1095,73 +1095,73 @@ add_functions (void) /* Bessel and Neumann functions for G77 compatibility. */ add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, NULL, gfc_resolve_g77_math1, + gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_j0", GFC_STD_F2008); add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, NULL, gfc_resolve_g77_math1, + gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008); add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, NULL, gfc_resolve_g77_math1, + gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_j1", GFC_STD_F2008); add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, NULL, gfc_resolve_g77_math1, + gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008); add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_besn, NULL, gfc_resolve_besn, + gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_jn", GFC_STD_F2008); add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_besn, NULL, gfc_resolve_besn, + gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008); add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, NULL, gfc_resolve_g77_math1, + gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_y0", GFC_STD_F2008); add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, NULL, gfc_resolve_g77_math1, + gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008); add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, NULL, gfc_resolve_g77_math1, + gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_y1", GFC_STD_F2008); add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, NULL, gfc_resolve_g77_math1, + gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008); add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_besn, NULL, gfc_resolve_besn, + gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); make_alias ("bessel_yn", GFC_STD_F2008); add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_besn, NULL, gfc_resolve_besn, + gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 91645fbb1e5..ac996b62a57 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -208,6 +208,12 @@ gfc_expr *gfc_simplify_asinh (gfc_expr *); gfc_expr *gfc_simplify_atan (gfc_expr *); gfc_expr *gfc_simplify_atanh (gfc_expr *); gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *); +gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *); +gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bessel_y0 (gfc_expr *); +gfc_expr *gfc_simplify_bessel_y1 (gfc_expr *); +gfc_expr *gfc_simplify_bessel_yn (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bit_size (gfc_expr *); gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 9d3553da111..571f10e893f 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -361,7 +361,7 @@ end program test_abort @code{ABS(X)} computes the absolute value of @code{X}. @item @emph{Standard}: -F77 and later, has overloads that are GNU extensions +Fortran 77 and later, has overloads that are GNU extensions @item @emph{Class}: Elemental function @@ -395,9 +395,9 @@ end program test_abs @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{CABS(Z)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab F77 and later -@item @code{DABS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later -@item @code{IABS(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab F77 and later +@item @code{CABS(Z)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DABS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{IABS(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later @item @code{ZABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension @item @code{CDABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @@ -475,17 +475,20 @@ end program access_test in the @acronym{ASCII} collating sequence. @item @emph{Standard}: -F77 and later +Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @item @emph{Syntax}: -@code{RESULT = ACHAR(I)} +@code{RESULT = ACHAR(I [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{I} @tab The type shall be @code{INTEGER(*)}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization + expression indicating the kind parameter of + the result. @end multitable @item @emph{Return value}: @@ -523,7 +526,7 @@ and formatted string representations. @code{ACOS(X)} computes the arccosine of @var{X} (inverse of @code{COS(X)}). @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -553,7 +556,7 @@ end program test_acos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -626,7 +629,7 @@ Inverse function: @ref{COSH} Spaces are inserted at the end of the string as needed. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -671,7 +674,7 @@ end program test_adjustl Spaces are inserted at the start of the string as needed. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -720,7 +723,7 @@ for compatibility with @command{g77}, and their use in new code is strongly discouraged. @item @emph{Standard}: -F77 and later, has overloads that are GNU extensions +Fortran 77 and later, has overloads that are GNU extensions @item @emph{Class}: Elemental function @@ -771,7 +774,7 @@ end program test_aimag @code{AINT(X [, KIND])} truncates its argument to a whole number. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -811,7 +814,7 @@ end program test_aint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -880,7 +883,7 @@ after 3 seconds. in the array along dimension @var{DIM}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -945,7 +948,7 @@ end program test_all @code{ALLOCATED(X)} checks the status of whether @var{X} is allocated. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -1000,13 +1003,16 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{I} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. -@item @var{J} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. +@item @var{I} @tab The type shall be either a scalar @code{INTEGER(*)} +type or a scalar @code{LOGICAL} type. +@item @var{J} @tab The type shall be the same as the type of @var{I}. @end multitable @item @emph{Return value}: -The return type is either @code{INTEGER(*)} or @code{LOGICAL} after -cross-promotion of the arguments. +The return type is either a scalar @code{INTEGER(*)} or a scalar +@code{LOGICAL}. If the kind type parameters differ, then the +smaller kind type is implicitly converted to larger kind, and the +return has the larger kind. @item @emph{Example}: @smallexample @@ -1021,7 +1027,7 @@ END PROGRAM @end smallexample @item @emph{See also}: -F95 elemental function: @ref{IAND} +Fortran 95 elemental function: @ref{IAND} @end table @@ -1038,7 +1044,7 @@ F95 elemental function: @ref{IAND} @code{ANINT(X [, KIND])} rounds its argument to the nearest whole number. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -1076,7 +1082,7 @@ end program test_anint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DNINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DNINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -1094,7 +1100,7 @@ end program test_anint @var{MASK} along dimension @var{DIM} are @code{.TRUE.}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -1161,7 +1167,7 @@ end program test_any @code{ASIN(X)} computes the arcsine of its @var{X} (inverse of @code{SIN(X)}). @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -1191,7 +1197,7 @@ end program test_asin @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DASIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DASIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -1263,7 +1269,7 @@ Inverse function: @ref{SINH} or if @var{PTR} is associated with the target @var{TGT}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -1339,7 +1345,7 @@ end program test_associated @code{ATAN(X)} computes the arctangent of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -1367,7 +1373,7 @@ end program test_atan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DATAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DATAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -1390,7 +1396,7 @@ Inverse function: @ref{TAN} @math{X + i Y}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -1425,7 +1431,7 @@ end program test_atan2 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DATAN2(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DATAN2(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -1786,7 +1792,7 @@ end program test_besyn represented by the type of @var{I}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -1826,7 +1832,7 @@ end program test_bit_size in @var{I} is set. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -2135,7 +2141,7 @@ end subroutine association_test @code{CEILING(X)} returns the least integer greater than or equal to @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -2181,7 +2187,7 @@ end program test_ceiling @code{CHAR(I [, KIND])} returns the character represented by the integer @var{I}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -2354,7 +2360,7 @@ component. If @var{Y} is not present then the imaginary component is set to 0.0. If @var{X} is complex then @var{Y} must not be present. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -2504,7 +2510,7 @@ end program test_complex then the result is @code{(x, -y)} @item @emph{Standard}: -F77 and later, has overloads that are GNU extensions +Fortran 77 and later, has overloads that are GNU extensions @item @emph{Class}: Elemental function @@ -2556,7 +2562,7 @@ end program test_conjg @code{COS(X)} computes the cosine of @var{X}. @item @emph{Standard}: -F77 and later, has overloads that are GNU extensions +Fortran 77 and later, has overloads that are GNU extensions @item @emph{Class}: Elemental function @@ -2586,8 +2592,8 @@ end program test_cos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later -@item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab F77 and later +@item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @item @code{ZCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @item @code{CDCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @@ -2612,7 +2618,7 @@ Inverse function: @ref{ACOS} @code{COSH(X)} computes the hyperbolic cosine of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -2640,7 +2646,7 @@ end program test_cosh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DCOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{DCOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -2667,7 +2673,7 @@ omitted it is taken to be @code{1}. @var{DIM} is a scaler of type is the rank of @var{MASK}. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Transformational function @@ -2739,7 +2745,7 @@ this subroutine, as shown in the example below, should be used. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Subroutine @@ -2791,7 +2797,7 @@ sections of @var{ARRAY} along the given dimension are shifted. Elements shifted out one end of each rank one section are shifted back in the other end. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -2914,7 +2920,7 @@ Unavailable time and date parameters return blanks. @end multitable @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Subroutine @@ -2966,7 +2972,7 @@ end program test_time_and_date @code{DBLE(X)} Converts @var{X} to double precision real type. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -3101,7 +3107,7 @@ representation of @var{X}. For example, on a system using a 32-bit floating point representation, a default real number would likely return 24. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -3145,7 +3151,7 @@ end program test_digits otherwise returns zero. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -3177,8 +3183,8 @@ end program test_dim @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X,Y} @tab @code{INTEGER(4)} @tab F77 and later -@item @code{DDIM(X,Y)} @tab @code{REAL(8) X,Y} @tab @code{REAL(8)} @tab F77 and later +@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X,Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{DDIM(X,Y)} @tab @code{REAL(8) X,Y} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -3201,7 +3207,7 @@ vectors are @code{COMPLEX(*)}, the result is @code{SUM(CONJG(X)*Y)}. If the vectors are @code{LOGICAL}, the result is @code{ANY(X.AND.Y)}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -3247,7 +3253,7 @@ end program test_dot_prod @code{DPROD(X,Y)} returns the product @code{X*Y}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -3435,7 +3441,7 @@ following are copied in depending on the type of @var{ARRAY}. @end multitable @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -3483,7 +3489,7 @@ end program test_eoshift @code{EPSILON(X)} returns a nearly negligible number relative to @code{1}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -3774,7 +3780,7 @@ end program test_exit @code{EXP(X)} computes the base @math{e} exponential of @var{X}. @item @emph{Standard}: -F77 and later, has overloads that are GNU extensions +Fortran 77 and later, has overloads that are GNU extensions @item @emph{Class}: Elemental function @@ -3802,8 +3808,8 @@ end program test_exp @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DEXP(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later -@item @code{CEXP(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab F77 and later +@item @code{DEXP(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{CEXP(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @item @code{ZEXP(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @item @code{CDEXP(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @@ -3823,7 +3829,7 @@ end program test_exp is zero the value returned is zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -3920,7 +3926,7 @@ end program test_fdate @code{FLOAT(I)} converts the integer @var{I} to a default real value. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -4082,7 +4088,7 @@ END PROGRAM @code{FLOOR(X)} returns the greatest integer less than or equal to @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -4315,7 +4321,7 @@ END PROGRAM representation of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5206,7 +5212,7 @@ be obtained, or to a blank string otherwise. the model of the type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -5286,7 +5292,7 @@ end program test_hypot in the first character position of @code{C}. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -5336,7 +5342,7 @@ and formatted string representations. Bitwise logical @code{AND}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5429,7 +5435,7 @@ Fortran 2003 functions and subroutines: @ref{GET_COMMAND}, @var{POS} set to zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5469,7 +5475,7 @@ zeroed. The value of @code{POS+LEN} must be less than or equal to the value @code{BIT_SIZE(I)}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5505,7 +5511,7 @@ The return value is of type @code{INTEGER(*)} and of the same kind as @var{POS} set to one. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5543,7 +5549,7 @@ The correspondence between characters and their codes is not necessarily the same across different GNU Fortran implementations. @item @emph{Standard}: -F95 and later +Fortan 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -5658,7 +5664,7 @@ end program test_idate @var{J}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -5732,7 +5738,7 @@ the @var{BACK} argument is present and true, the return value is the start of the last occurrence rather than the first. @item @emph{Standard}: -F77 and later +Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -5775,7 +5781,7 @@ The return value is of type @code{INTEGER} and of kind @var{KIND}. If Convert to integer type @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -5820,8 +5826,8 @@ end program @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{IFIX(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab F77 and later -@item @code{IDINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab F77 and later +@item @code{IFIX(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later +@item @code{IDINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 77 and later @end multitable @end table @@ -5843,7 +5849,7 @@ standard @code{INT} intrinsic with an optional argument of The @code{SHORT} intrinsic is equivalent to @code{INT2}. @item @emph{Standard}: -GNU extension. +GNU extension @item @emph{Class}: Elemental function @@ -5878,7 +5884,7 @@ standard @code{INT} intrinsic with an optional argument of @code{KIND=8}, and is only included for backwards compatibility. @item @emph{Standard}: -GNU extension. +GNU extension @item @emph{Class}: Elemental function @@ -5913,7 +5919,7 @@ The return value is a @code{INTEGER(8)} variable. @var{J}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -6091,7 +6097,7 @@ END PROGRAM Determine whether a unit is connected to a terminal device. @item @emph{Standard}: -GNU extension. +GNU extension @item @emph{Class}: Function @@ -6139,7 +6145,7 @@ value is undefined. Bits shifted out from the left end or right end are lost; zeros are shifted in from the opposite end. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -6180,7 +6186,7 @@ a right shift. The absolute value of @var{SHIFT} must be less than equivalent to @code{BIT_SIZE(I)}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -6341,7 +6347,7 @@ Subroutine, function @code{KIND(X)} returns the kind value of the entity @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -6384,7 +6390,7 @@ end program test_kind Returns the lower bounds of an array, or a single lower bound along the @var{DIM} dimension. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Inquiry function @@ -6430,7 +6436,7 @@ the length of an element of @var{STRING} is returned. Note that only the length, not the content, of @var{STRING} is needed. @item @emph{Standard}: -F77 and later +Fortran 77 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Inquiry function @@ -6467,7 +6473,7 @@ The return value is of type @code{INTEGER} and of kind @var{KIND}. If Returns the length of a character string, ignoring any trailing blanks. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -6570,7 +6576,7 @@ ASCII on some targets), whereas the former always use the ASCII ordering. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6616,7 +6622,7 @@ ASCII on some targets), whereas the former always use the ASCII ordering. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6705,7 +6711,7 @@ ASCII on some targets), whereas the former always use the ASCII ordering. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6751,7 +6757,7 @@ ASCII on some targets), whereas the former always use the ASCII ordering. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6867,7 +6873,7 @@ end program test_loc @code{LOG(X)} computes the logarithm of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6921,7 +6927,7 @@ end program test_log @code{LOG10(X)} computes the base 10 logarithm of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -6949,8 +6955,8 @@ end program test_log10 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{ALOG10(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab F95 and later -@item @code{DLOG10(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F95 and later +@item @code{ALOG10(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 95 and later +@item @code{DLOG10(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @end table @@ -6966,7 +6972,7 @@ end program test_log10 Converts one kind of @code{LOGICAL} variable to another. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -7006,7 +7012,7 @@ intrinsic with an optional argument of @code{KIND=4}, and is only included for backwards compatibility. @item @emph{Standard}: -GNU extension. +GNU extension @item @emph{Class}: Elemental function @@ -7242,7 +7248,7 @@ end program test_malloc Performs a matrix multiplication on numeric or logical arguments. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -7291,7 +7297,7 @@ for the @code{*} or @code{.AND.} operators. Returns the argument with the largest (most positive) value. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -7316,11 +7322,11 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{MAX0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab F77 and later -@item @code{AMAX0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MAX(X))} @tab F77 and later -@item @code{MAX1(X)} @tab @code{REAL(*) X} @tab @code{INT(MAX(X))} @tab F77 and later -@item @code{AMAX1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab F77 and later -@item @code{DMAX1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{MAX0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{AMAX0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later +@item @code{MAX1(X)} @tab @code{REAL(*) X} @tab @code{INT(MAX(X))} @tab Fortran 77 and later +@item @code{AMAX1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DMAX1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -7341,7 +7347,7 @@ and has the same type and kind as the first argument. type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -7392,7 +7398,7 @@ and all of the elements of @var{MASK} along a given row are zero, the result value for that row is zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -7449,7 +7455,7 @@ number of the type and kind of @var{ARRAY} if @var{ARRAY} is numeric, or a string of nulls if @var{ARRAY} is of character type. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -7576,7 +7582,7 @@ is equal to @var{TSOURCE} if @var{MASK} is @code{.TRUE.}, or equal to @var{FSOURCE} if it is @code{.FALSE.}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -7614,7 +7620,7 @@ The result is of the same type and type parameters as @var{TSOURCE}. Returns the argument with the smallest (most negative) value. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -7639,11 +7645,11 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{MIN0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab F77 and later -@item @code{AMIN0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MIN(X))} @tab F77 and later -@item @code{MIN1(X)} @tab @code{REAL(*) X} @tab @code{INT(MIN(X))} @tab F77 and later -@item @code{AMIN1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab F77 and later -@item @code{DMIN1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F77 and later +@item @code{MIN0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{AMIN0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MIN(X))} @tab Fortran 77 and later +@item @code{MIN1(X)} @tab @code{REAL(*) X} @tab @code{INT(MIN(X))} @tab Fortran 77 and later +@item @code{AMIN1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DMIN1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -7663,7 +7669,7 @@ and has the same type and kind as the first argument. type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -7706,7 +7712,7 @@ and all of the elements of @var{MASK} along a given row are zero, the result value for that row is zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -7763,7 +7769,7 @@ considered. If the array has zero size, or all of the elements of @var{ARRAY} is of character type. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -7814,7 +7820,7 @@ cases, the result is of the same type and kind as @var{ARRAY}. calculated as @code{A - (INT(A/P) * P)}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -7856,8 +7862,8 @@ end program test_mod @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Arguments @tab Return type @tab Standard -@item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab F95 and later -@item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab F95 and later +@item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab Fortran 95 and later +@item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @end table @@ -7874,7 +7880,7 @@ end program test_mod @code{MODULO(A,P)} computes the @var{A} modulo @var{P}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -7980,7 +7986,7 @@ affected by the movement of bits is unchanged. The values of @code{BIT_SIZE(FROM)}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental subroutine @@ -8016,7 +8022,7 @@ Elemental subroutine to @code{X} in the direction indicated by the sign of @code{S}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -8102,17 +8108,20 @@ end program newline @code{NINT(X)} rounds its argument to the nearest whole number. @item @emph{Standard}: -F77 and later +Fortran 77 and later, with @var{KIND} argument Fortran 90 and later @item @emph{Class}: Elemental function @item @emph{Syntax}: -@code{RESULT = NINT(X)} +@code{RESULT = NINT(X [, KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{X} @tab The type of the argument shall be @code{REAL}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization + expression indicating the kind parameter of + the result. @end multitable @item @emph{Return value}: @@ -8134,7 +8143,7 @@ end program test_nint @item @emph{Specific names}: @multitable @columnfractions .25 .25 .25 @item Name @tab Argument @tab Standard -@item @code{IDNINT(X)} @tab @code{REAL(8)} @tab F95 and later +@item @code{IDNINT(X)} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -8156,7 +8165,7 @@ end program test_nint @code{NOT} returns the bitwise boolean inverse of @var{I}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -8197,7 +8206,7 @@ In Fortran 95, @var{MOLD} is optional. Please note that Fortran 2003 includes cases where it is required. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -8250,13 +8259,16 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. -@item @var{Y} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. +@item @var{X} @tab The type shall be either a scalar @code{INTEGER(*)} +type or a scalar @code{LOGICAL} type. +@item @var{Y} @tab The type shall be the same as the type of @var{X}. @end multitable @item @emph{Return value}: -The return type is either @code{INTEGER(*)} or @code{LOGICAL} -after cross-promotion of the arguments. +The return type is either a scalar @code{INTEGER(*)} or a scalar +@code{LOGICAL}. If the kind type parameters differ, then the +smaller kind type is implicitly converted to larger kind, and the +return has the larger kind. @item @emph{Example}: @smallexample @@ -8271,7 +8283,7 @@ END PROGRAM @end smallexample @item @emph{See also}: -F95 elemental function: @ref{IOR} +Fortran 95 elemental function: @ref{IOR} @end table @@ -8292,7 +8304,7 @@ equals @code{TRUE}. Afterwards, positions are filled with elements taken from @var{VECTOR}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -8386,7 +8398,7 @@ Subroutine type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -8426,7 +8438,7 @@ end program prec_and_range Determines whether an optional dummy argument is present. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -8474,7 +8486,7 @@ Multiplies the elements of @var{ARRAY} along dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -8529,7 +8541,7 @@ END PROGRAM @code{RADIX(X)} returns the base of the model representing the entity @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -8663,7 +8675,7 @@ OpenMP-enabled application heavily relies on random numbers, one should consider employing a dedicated parallel random number generator instead. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Subroutine @@ -8707,7 +8719,7 @@ a default state. The example below shows how to initialize the random seed based on the system's time. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Subroutine @@ -8765,7 +8777,7 @@ END SUBROUTINE type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -8802,7 +8814,7 @@ See @code{PRECISION} for an example. and its use is strongly discouraged. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -8908,7 +8920,7 @@ Subroutine, function Concatenates @var{NCOPIES} copies of a string. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -8949,7 +8961,7 @@ the new array may be padded with elements from @var{PAD} or permuted as defined by @var{ORDER}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -9003,7 +9015,7 @@ END PROGRAM model numbers near @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -9080,7 +9092,7 @@ The return value is of type @code{INTEGER(*)} and of the same kind as @code{SCALE(X,I)} returns @code{X * RADIX(X)**I}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -9128,7 +9140,7 @@ is returned. If no character of @var{SET} is found in @var{STRING}, the result is zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -9313,7 +9325,7 @@ to @math{10^I} (exclusive). If there is no integer kind that accommodates this range, @code{SELECTED_INT_KIND} returns @math{-1}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -9358,7 +9370,7 @@ with decimal precision greater of at least @code{P} digits and exponent range greater at least @code{R}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -9420,7 +9432,7 @@ end program real_kinds is that that of @var{X} and whose exponent part is @var{I}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -9463,7 +9475,7 @@ END PROGRAM Determines the shape of an array. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -9511,7 +9523,7 @@ END PROGRAM @code{SIGN(A,B)} returns the value of @var{A} with the sign of @var{B}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -9625,7 +9637,7 @@ end program test_signal @code{SIN(X)} computes the sine of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -9678,7 +9690,7 @@ end program test_sin @code{SINH(X)} computes the hyperbolic sine of @var{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -9705,7 +9717,7 @@ end program test_sinh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DSINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F95 and later +@item @code{DSINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -9727,7 +9739,7 @@ Determine the extent of @var{ARRAY} along a specified dimension @var{DIM}, or the total number of elements in @var{ARRAY} if @var{DIM} is absent. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Inquiry function @@ -9853,7 +9865,7 @@ to a default real value. This is an archaic form of @code{REAL} that is specific to one type for @var{A}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -9887,7 +9899,7 @@ Determines the distance between the argument @var{X} and the nearest adjacent number of the same type. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Elemental function @@ -9933,7 +9945,7 @@ Replicates a @var{SOURCE} array @var{NCOPIES} times along a specified dimension @var{DIM}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -9984,7 +9996,7 @@ END PROGRAM @code{SQRT(X)} computes the square root of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -10015,8 +10027,8 @@ end program test_sqrt @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DSQRT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F95 and later -@item @code{CSQRT(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab F95 and later +@item @code{DSQRT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later +@item @code{CSQRT(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 95 and later @item @code{ZSQRT(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @item @code{CDSQRT(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @@ -10169,7 +10181,7 @@ Adds the elements of @var{ARRAY} along dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -10314,7 +10326,7 @@ If there is no clock, @var{COUNT} is set to @code{-HUGE(COUNT)}, and @var{COUNT_RATE} and @var{COUNT_MAX} are set to zero @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Subroutine @@ -10360,7 +10372,7 @@ END PROGRAM @code{TAN(X)} computes the tangent of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -10388,7 +10400,7 @@ end program test_tan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F95 and later +@item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -10410,7 +10422,7 @@ end program test_tan @code{TANH(X)} computes the hyperbolic tangent of @var{X}. @item @emph{Standard}: -F77 and later +Fortran 77 and later @item @emph{Class}: Elemental function @@ -10438,7 +10450,7 @@ end program test_tanh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DTANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab F95 and later +@item @code{DTANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -10539,7 +10551,7 @@ The return value is a scalar of type @code{INTEGER(8)}. in the model of the type of @code{X}. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Inquiry function @@ -10577,7 +10589,7 @@ This is approximately equivalent to the C concept of @emph{casting} one type to another. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -10637,7 +10649,7 @@ Transpose an array of rank two. Element (i, j) of the result has the value @code{MATRIX(j, i)}, for all i, j. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -10667,7 +10679,7 @@ The result has the same type as @var{MATRIX}, and has shape Removes trailing blank characters of a string. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -10755,7 +10767,7 @@ END PROGRAM Returns the upper bounds of an array, or a single upper bound along the @var{DIM} dimension. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Inquiry function @@ -10871,7 +10883,7 @@ Subroutine, function Store the elements of @var{VECTOR} in an array of higher rank. @item @emph{Standard}: -F95 and later +Fortran 95 and later @item @emph{Class}: Transformational function @@ -10926,7 +10938,7 @@ is returned. If all characters of @var{SET} are found in @var{STRING}, the result is zero. @item @emph{Standard}: -F95 and later +Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later @item @emph{Class}: Elemental function @@ -10990,13 +11002,16 @@ Function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. -@item @var{Y} @tab The type shall be either @code{INTEGER(*)} or @code{LOGICAL}. +@item @var{X} @tab The type shall be either a scalar @code{INTEGER(*)} +type or a scalar @code{LOGICAL} type. +@item @var{Y} @tab The type shall be the same as the type of @var{I}. @end multitable @item @emph{Return value}: -The return type is either @code{INTEGER(*)} or @code{LOGICAL} -after cross-promotion of the arguments. +The return type is either a scalar @code{INTEGER(*)} or a scalar +@code{LOGICAL}. If the kind type parameters differ, then the +smaller kind type is implicitly converted to larger kind, and the +return has the larger kind. @item @emph{Example}: @smallexample @@ -11011,7 +11026,7 @@ END PROGRAM @end smallexample @item @emph{See also}: -F95 elemental function: @ref{IEOR} +Fortran 95 elemental function: @ref{IEOR} @end table @@ -11064,7 +11079,7 @@ Identifies the preconnected unit identified by the asterisk @section @code{ISO_C_BINDING} @table @asis @item @emph{Standard}: -Fortran 2003 and later +Fortran 2003 and later, GNU extensions @end table The following intrinsic procedures are provided by the module; their @@ -11086,8 +11101,13 @@ parameters (marked by an asterisk (@code{*}) in the list below). The @code{C_INT_FAST...} parameters have therefore the value @math{-2} and cannot be used as KIND type parameter of the @code{INTEGER} type. -@multitable @columnfractions .15 .35 .35 -@item Fortran Type @tab Named constant @tab C type +In addition to the integer named constants required by the Fortran 2003 +standard, GNU Fortran provides as an extension named constants for the +128-bit integer types supported by the C compiler: @code{C_INT128_T, +C_INT_LEAST128_T, C_INT_FAST128_T}. + +@multitable @columnfractions .15 .35 .35 .35 +@item Fortran Type @tab Named constant @tab C type @tab Extension @item @code{INTEGER}@tab @code{C_INT} @tab @code{int} @item @code{INTEGER}@tab @code{C_SHORT} @tab @code{short int} @item @code{INTEGER}@tab @code{C_LONG} @tab @code{long int} @@ -11098,14 +11118,17 @@ and cannot be used as KIND type parameter of the @code{INTEGER} type. @item @code{INTEGER}@tab @code{C_INT16_T} @tab @code{int16_t} @item @code{INTEGER}@tab @code{C_INT32_T} @tab @code{int32_t} @item @code{INTEGER}@tab @code{C_INT64_T} @tab @code{int64_t} +@item @code{INTEGER}@tab @code{C_INT128_T} @tab @code{int128_t} @tab Ext. @item @code{INTEGER}@tab @code{C_INT_LEAST8_T} @tab @code{int_least8_t} @item @code{INTEGER}@tab @code{C_INT_LEAST16_T} @tab @code{int_least16_t} @item @code{INTEGER}@tab @code{C_INT_LEAST32_T} @tab @code{int_least32_t} @item @code{INTEGER}@tab @code{C_INT_LEAST64_T} @tab @code{int_least64_t} +@item @code{INTEGER}@tab @code{C_INT_LEAST128_T} @tab @code{int_least128_t} @tab Ext. @item @code{INTEGER}@tab @code{C_INT_FAST8_T}* @tab @code{int_fast8_t} @item @code{INTEGER}@tab @code{C_INT_FAST16_T}* @tab @code{int_fast16_t} @item @code{INTEGER}@tab @code{C_INT_FAST32_T}* @tab @code{int_fast32_t} @item @code{INTEGER}@tab @code{C_INT_FAST64_T}* @tab @code{int_fast64_t} +@item @code{INTEGER}@tab @code{C_INT_FAST128_T}* @tab @code{int_fast128_t} @tab Ext. @item @code{INTEGER}@tab @code{C_INTMAX_T} @tab @code{intmax_t} @item @code{INTEGER}@tab @code{C_INTPTR_T} @tab @code{intptr_t} @item @code{REAL} @tab @code{C_FLOAT} @tab @code{float} diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 712aa2140c3..88ede3b2a13 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -237,13 +237,17 @@ Allow @samp{$} as a valid character in a symbol name. @opindex @code{backslash} @cindex backslash @cindex escape characters -Change the interpretation of backslashes in string literals -from a single backslash character to ``C-style'' escape characters. -The following combinations are expanded \a, \b, \f, \n, \r, \t, -\v, \\, and \0 to the ASCII characters alert, backspace, form feed, -newline, carriage return, horizontal tab, vertical tab, backslash, -and NUL, respectively. All other combinations of a character preceded -by \ are unexpanded. +Change the interpretation of backslashes in string literals from a single +backslash character to ``C-style'' escape characters. The following +combinations are expanded @code{\a}, @code{\b}, @code{\f}, @code{\n}, +@code{\r}, @code{\t}, @code{\v}, @code{\\}, and @code{\0} to the ASCII +characters alert, backspace, form feed, newline, carriage return, +horizontal tab, vertical tab, backslash, and NUL, respectively. +Additionally, @code{\x}@var{nn}, @code{\u}@var{nnnn} and +@code{\U}@var{nnnnnnnn} (where each @var{n} is a hexadecimal digit) are +translated into the Unicode characters corresponding to the specified code +points. All other combinations of a character preceded by \ are +unexpanded. @item -fmodule-private @opindex @code{fmodule-private} diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 4eb76309ede..736253fe159 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -117,7 +117,7 @@ format_token; /* Local variables for checking format strings. The saved_token is used to back up by a single format token during the parsing process. */ -static char *format_string; +static gfc_char_t *format_string; static int format_length, use_last_char; static format_token saved_token; @@ -132,7 +132,7 @@ mode; static char next_char (int in_string) { - static char c; + static gfc_char_t c; if (use_last_char) { @@ -153,18 +153,11 @@ next_char (int in_string) if (gfc_option.flag_backslash && c == '\\') { - int tmp; locus old_locus = gfc_current_locus; - /* Use a temp variable to avoid side effects from gfc_match_special_char - since it uses an int * for its argument. */ - tmp = (int)c; - - if (gfc_match_special_char (&tmp) == MATCH_NO) + if (gfc_match_special_char (&c) == MATCH_NO) gfc_current_locus = old_locus; - c = (char)tmp; - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) gfc_warning ("Extension: backslash character at %C"); } @@ -172,7 +165,7 @@ next_char (int in_string) if (mode == MODE_COPY) *format_string++ = c; - c = TOUPPER (c); + c = gfc_wide_toupper (c); return c; } @@ -789,7 +782,7 @@ data_desc: gfc_warning ("The H format specifier at %C is" " a Fortran 95 deleted feature"); - if(mode == MODE_STRING) + if (mode == MODE_STRING) { format_string += value; format_length -= value; @@ -1017,7 +1010,8 @@ gfc_match_format (void) e->ts.type = BT_CHARACTER; e->ts.kind = gfc_default_character_kind; e->where = start; - e->value.character.string = format_string = gfc_getmem (format_length + 1); + e->value.character.string = format_string + = gfc_get_wide_string (format_length + 1); e->value.character.length = format_length; gfc_statement_label->format = e; @@ -1419,13 +1413,13 @@ gfc_resolve_open (gfc_open *open) static int compare_to_allowed_values (const char *specifier, const char *allowed[], const char *allowed_f2003[], - const char *allowed_gnu[], char *value, + const char *allowed_gnu[], gfc_char_t *value, const char *statement, bool warn) { int i; unsigned int len; - len = strlen (value); + len = gfc_wide_strlen (value); if (len > 0) { for (len--; len > 0; len--) @@ -1436,13 +1430,13 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], for (i = 0; allowed[i]; i++) if (len == strlen (allowed[i]) - && strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) + && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) return 1; for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) if (len == strlen (allowed_f2003[i]) - && strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i])) - == 0) + && gfc_wide_strncasecmp (value, allowed_f2003[i], + strlen (allowed_f2003[i])) == 0) { notification n = gfc_notification_std (GFC_STD_F2003); @@ -1468,7 +1462,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], for (i = 0; allowed_gnu && allowed_gnu[i]; i++) if (len == strlen (allowed_gnu[i]) - && strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0) + && gfc_wide_strncasecmp (value, allowed_gnu[i], + strlen (allowed_gnu[i])) == 0) { notification n = gfc_notification_std (GFC_STD_GNU); @@ -1494,14 +1489,18 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (warn) { + char *s = gfc_widechar_to_char (value, -1); gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'", - specifier, statement, value); + specifier, statement, s); + gfc_free (s); return 1; } else { + char *s = gfc_widechar_to_char (value, -1); gfc_error ("%s specifier in %s statement at %C has invalid value '%s'", - specifier, statement, value); + specifier, statement, s); + gfc_free (s); return 0; } } @@ -1780,20 +1779,22 @@ gfc_match_open (void) /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, the FILE= specifier shall appear. */ if (open->file == NULL - && (strncasecmp (open->status->value.character.string, "replace", 7) - == 0 - || strncasecmp (open->status->value.character.string, "new", 3) - == 0)) + && (gfc_wide_strncasecmp (open->status->value.character.string, + "replace", 7) == 0 + || gfc_wide_strncasecmp (open->status->value.character.string, + "new", 3) == 0)) { + char *s = gfc_widechar_to_char (open->status->value.character.string, + -1); warn_or_error ("The STATUS specified in OPEN statement at %C is " - "'%s' and no FILE specifier is present", - open->status->value.character.string); + "'%s' and no FILE specifier is present", s); + gfc_free (s); } /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, the FILE= specifier shall not appear. */ - if (strncasecmp (open->status->value.character.string, "scratch", 7) - == 0 && open->file) + if (gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) == 0 && open->file) { warn_or_error ("The STATUS specified in OPEN statement at %C " "cannot have the value SCRATCH if a FILE specifier " @@ -1805,8 +1806,8 @@ gfc_match_open (void) if (open->form && open->form->expr_type == EXPR_CONSTANT && (open->delim || open->decimal || open->encoding || open->round || open->sign || open->pad || open->blank) - && strncasecmp (open->form->value.character.string, - "unformatted", 11) == 0) + && gfc_wide_strncasecmp (open->form->value.character.string, + "unformatted", 11) == 0) { const char *spec = (open->delim ? "DELIM " : (open->pad ? "PAD " : open->blank @@ -1817,7 +1818,8 @@ gfc_match_open (void) } if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT - && strncasecmp (open->access->value.character.string, "stream", 6) == 0) + && gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0) { warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " "stream I/O"); @@ -1825,12 +1827,12 @@ gfc_match_open (void) if (open->position && open->access && open->access->expr_type == EXPR_CONSTANT - && !(strncasecmp (open->access->value.character.string, - "sequential", 10) == 0 - || strncasecmp (open->access->value.character.string, - "stream", 6) == 0 - || strncasecmp (open->access->value.character.string, - "append", 6) == 0)) + && !(gfc_wide_strncasecmp (open->access->value.character.string, + "sequential", 10) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "append", 6) == 0)) { warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " "for stream or sequential ACCESS"); @@ -2946,9 +2948,12 @@ if (condition) \ if (dt->id) { - io_constraint (!dt->asynchronous - || strcmp (dt->asynchronous->value.character.string, - "yes"), + bool not_yes + = !dt->asynchronous + || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 + || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, + "yes", 3) != 0; + io_constraint (not_yes, "ID= specifier at %L must be with ASYNCHRONOUS='yes' " "specifier", &dt->id->where); } @@ -3144,9 +3149,11 @@ if (condition) \ if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) { - const char * advance = expr->value.character.string; - not_no = strcasecmp (advance, "no") != 0; - not_yes = strcasecmp (advance, "yes") != 0; + const gfc_char_t *advance = expr->value.character.string; + not_no = gfc_wide_strlen (advance) != 2 + || gfc_wide_strncasecmp (advance, "no", 2) != 0; + not_yes = gfc_wide_strlen (advance) != 3 + || gfc_wide_strncasecmp (advance, "yes", 3) != 0; } else { @@ -3185,7 +3192,7 @@ match_io (io_kind k) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_code *io_code; gfc_symbol *sym; - int comma_flag, c; + int comma_flag; locus where; locus spec_end; gfc_dt *dt; @@ -3203,7 +3210,7 @@ match_io (io_kind k) else if (k == M_PRINT) { /* Treat the non-standard case of PRINT namelist. */ - if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ') + if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') && gfc_match_name (name) == MATCH_YES) { gfc_find_symbol (name, NULL, 1, &sym); @@ -3227,7 +3234,7 @@ match_io (io_kind k) if (gfc_current_form == FORM_FREE) { - c = gfc_peek_char(); + char c = gfc_peek_ascii_char (); if (c != ' ' && c != '*' && c != '\'' && c != '"') { m = MATCH_NO; diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def index c41870d4998..98c3c982267 100644 --- a/gcc/fortran/iso-c-binding.def +++ b/gcc/fortran/iso-c-binding.def @@ -20,7 +20,7 @@ along with GCC; see the file COPYING3. If not see Fortran 2003 ISO_C_BINDING intrinsic module. */ #ifndef NAMED_INTCST -# define NAMED_INTCST(a,b,c) +# define NAMED_INTCST(a,b,c,d) #endif #ifndef NAMED_REALCST @@ -42,44 +42,57 @@ along with GCC; see the file COPYING3. If not see /* The arguments to NAMED_*CST are: -- an internal name -- the symbol name in the module, as seen by Fortran code - -- the value it has, for use in trans-types.c */ + -- the value it has, for use in trans-types.c + -- the standard that supports this type */ -NAMED_INTCST (ISOCBINDING_INT, "c_int", gfc_c_int_kind) +NAMED_INTCST (ISOCBINDING_INT, "c_int", gfc_c_int_kind, GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_SHORT, "c_short", \ - get_int_kind_from_node (short_integer_type_node)) + get_int_kind_from_node (short_integer_type_node), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_LONG, "c_long", \ - get_int_kind_from_node (long_integer_type_node)) + get_int_kind_from_node (long_integer_type_node), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_LONG_LONG, "c_long_long", \ - get_int_kind_from_node (long_long_integer_type_node)) + get_int_kind_from_node (long_long_integer_type_node), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \ - get_int_kind_from_node (intmax_type_node)) + get_int_kind_from_node (intmax_type_node), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \ - get_int_kind_from_node (ptr_type_node)) + get_int_kind_from_node (ptr_type_node), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \ - gfc_index_integer_kind) + gfc_index_integer_kind, GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \ - get_int_kind_from_node (signed_char_type_node)) - -NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", get_int_kind_from_width (8)) -NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", get_int_kind_from_width (16)) -NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", get_int_kind_from_width (32)) -NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", get_int_kind_from_width (64)) + get_int_kind_from_node (signed_char_type_node), GFC_STD_F2003) + +NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", get_int_kind_from_width (8), \ + GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", get_int_kind_from_width (16), \ + GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", get_int_kind_from_width (32), \ + GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", get_int_kind_from_width (64), \ + GFC_STD_F2003) +/* GNU Extension. */ +NAMED_INTCST (ISOCBINDING_INT128_T, "c_int128_t", get_int_kind_from_width (128), \ + GFC_STD_GNU) NAMED_INTCST (ISOCBINDING_INT_LEAST8_T, "c_int_least8_t", \ - get_int_kind_from_minimal_width (8)) + get_int_kind_from_minimal_width (8), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INT_LEAST16_T, "c_int_least16_t", \ - get_int_kind_from_minimal_width (16)) + get_int_kind_from_minimal_width (16), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INT_LEAST32_T, "c_int_least32_t", \ - get_int_kind_from_minimal_width (32)) + get_int_kind_from_minimal_width (32), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INT_LEAST64_T, "c_int_least64_t", \ - get_int_kind_from_minimal_width (64)) + get_int_kind_from_minimal_width (64), GFC_STD_F2003) +/* GNU Extension. */ +NAMED_INTCST (ISOCBINDING_INT_LEAST128_T, "c_int_least128_t", \ + get_int_kind_from_minimal_width (128), GFC_STD_GNU) /* TODO: Implement c_int_fast*_t. Depends on PR 448. */ -NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", -2) -NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", -2) -NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", -2) -NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", -2) +NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", -2, GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", -2, GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", -2, GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", -2, GFC_STD_F2003) +/* GNU Extension. */ +NAMED_INTCST (ISOCBINDING_INT_FAST128_T, "c_int_fast128_t", -2, GFC_STD_GNU) NAMED_REALCST (ISOCBINDING_FLOAT, "c_float", \ get_real_kind_from_node (float_type_node)) diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index dba2d3521ad..5f2c04231c5 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -22,15 +22,22 @@ along with GCC; see the file COPYING3. If not see /* The arguments to NAMED_INTCST are: -- an internal name -- the symbol name in the module, as seen by Fortran code - -- the value it has */ + -- the value it has + -- the standard that supports this type */ NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \ - gfc_character_storage_size) -NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER) -NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8) -NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", GFC_STDIN_UNIT_NUMBER) -NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END) -NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR) + gfc_character_storage_size, GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \ + GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8, \ + GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", GFC_STDIN_UNIT_NUMBER, \ + GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END, \ + GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR, \ + GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \ - gfc_numeric_storage_size) -NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER) + gfc_numeric_storage_size, GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER, \ + GFC_STD_F2003) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 513dbd228ab..ccae391aebb 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -88,7 +88,7 @@ libgfortran_error_codes; #define GFC_STDERR_UNIT_NUMBER 0 -#define GFC_MAX_DIMENSIONS 7 +#define GFC_MAX_DIMENSIONS 15 #define GFC_DTYPE_RANK_MASK 0x07 #define GFC_DTYPE_TYPE_SHIFT 3 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 8512d03a0fb..d3f665f4440 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -111,8 +111,8 @@ match gfc_match_parens (void) { locus old_loc, where; - int c, count, instring; - char quote; + int count, instring; + gfc_char_t c, quote; old_loc = gfc_current_locus; count = 0; @@ -126,7 +126,7 @@ gfc_match_parens (void) break; if (quote == ' ' && ((c == '\'') || (c == '"'))) { - quote = (char) c; + quote = c; instring = 1; continue; } @@ -153,12 +153,12 @@ gfc_match_parens (void) if (count > 0) { - gfc_error ("Missing ')' in statement before %L", &where); + gfc_error ("Missing ')' in statement at or before %L", &where); return MATCH_ERROR; } if (count < 0) { - gfc_error ("Missing '(' in statement before %L", &where); + gfc_error ("Missing '(' in statement at or before %L", &where); return MATCH_ERROR; } @@ -170,42 +170,66 @@ gfc_match_parens (void) escaped by a \ via the -fbackslash option. */ match -gfc_match_special_char (int *c) +gfc_match_special_char (gfc_char_t *res) { - + int len, i; + gfc_char_t c, n; match m; m = MATCH_YES; - switch (gfc_next_char_literal (1)) + switch ((c = gfc_next_char_literal (1))) { case 'a': - *c = '\a'; + *res = '\a'; break; case 'b': - *c = '\b'; + *res = '\b'; break; case 't': - *c = '\t'; + *res = '\t'; break; case 'f': - *c = '\f'; + *res = '\f'; break; case 'n': - *c = '\n'; + *res = '\n'; break; case 'r': - *c = '\r'; + *res = '\r'; break; case 'v': - *c = '\v'; + *res = '\v'; break; case '\\': - *c = '\\'; + *res = '\\'; break; case '0': - *c = '\0'; + *res = '\0'; + break; + + case 'x': + case 'u': + case 'U': + /* Hexadecimal form of wide characters. */ + len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); + n = 0; + for (i = 0; i < len; i++) + { + char buf[2] = { '\0', '\0' }; + + c = gfc_next_char_literal (1); + if (!gfc_wide_fits_in_byte (c) + || !gfc_check_digit ((unsigned char) c, 16)) + return MATCH_NO; + + buf[0] = (unsigned char) c; + n = n << 4; + n += strtol (buf, NULL, 16); + } + *res = n; break; + default: /* Unknown backslash codes are simply not expanded. */ m = MATCH_NO; @@ -223,14 +247,14 @@ match gfc_match_space (void) { locus old_loc; - int c; + char c; if (gfc_current_form == FORM_FIXED) return MATCH_YES; old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!gfc_is_whitespace (c)) { gfc_current_locus = old_loc; @@ -251,7 +275,8 @@ match gfc_match_eos (void) { locus old_loc; - int flag, c; + int flag; + char c; flag = 0; @@ -260,13 +285,13 @@ gfc_match_eos (void) old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); switch (c) { case '!': do { - c = gfc_next_char (); + c = gfc_next_ascii_char (); } while (c != '\n'); @@ -302,8 +327,9 @@ gfc_match_small_literal_int (int *value, int *cnt) old_loc = gfc_current_locus; + *value = -1; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (cnt) *cnt = 0; @@ -319,7 +345,7 @@ gfc_match_small_literal_int (int *value, int *cnt) for (;;) { old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!ISDIGIT (c)) break; @@ -488,12 +514,13 @@ match gfc_match_name (char *buffer) { locus old_loc; - int i, c; + int i; + char c; old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore))) { if (gfc_error_flag_test() == 0 && c != '(') @@ -515,17 +542,17 @@ gfc_match_name (char *buffer) } old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); } while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$')); if (c == '$' && !gfc_option.flag_dollar_ok) { - gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it as an extension"); + gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it " + "as an extension"); return MATCH_ERROR; } - buffer[i] = '\0'; gfc_current_locus = old_loc; @@ -551,7 +578,7 @@ gfc_match_name_C (char *buffer) { locus old_loc; int i = 0; - int c; + gfc_char_t c; old_loc = gfc_current_locus; gfc_gobble_whitespace (); @@ -579,7 +606,9 @@ gfc_match_name_C (char *buffer) /* Continue to read valid variable name characters. */ do { - buffer[i++] = c; + gcc_assert (gfc_wide_fits_in_byte (c)); + + buffer[i++] = (unsigned char) c; /* C does not define a maximum length of variable names, to my knowledge, but the compiler typically places a limit on them. @@ -606,7 +635,7 @@ gfc_match_name_C (char *buffer) if (c == ' ') { gfc_gobble_whitespace (); - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); if (c != '"' && c != '\'') { gfc_error ("Embedded space in NAME= specifier at %C"); @@ -679,10 +708,10 @@ match gfc_match_intrinsic_op (gfc_intrinsic_op *result) { locus orig_loc = gfc_current_locus; - int ch; + char ch; gfc_gobble_whitespace (); - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); switch (ch) { case '+': @@ -696,7 +725,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) return MATCH_YES; case '=': - if (gfc_next_char () == '=') + if (gfc_next_ascii_char () == '=') { /* Matched "==". */ *result = INTRINSIC_EQ; @@ -705,10 +734,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case '<': - if (gfc_peek_char () == '=') + if (gfc_peek_ascii_char () == '=') { /* Matched "<=". */ - gfc_next_char (); + gfc_next_ascii_char (); *result = INTRINSIC_LE; return MATCH_YES; } @@ -717,10 +746,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) return MATCH_YES; case '>': - if (gfc_peek_char () == '=') + if (gfc_peek_ascii_char () == '=') { /* Matched ">=". */ - gfc_next_char (); + gfc_next_ascii_char (); *result = INTRINSIC_GE; return MATCH_YES; } @@ -729,10 +758,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) return MATCH_YES; case '*': - if (gfc_peek_char () == '*') + if (gfc_peek_ascii_char () == '*') { /* Matched "**". */ - gfc_next_char (); + gfc_next_ascii_char (); *result = INTRINSIC_POWER; return MATCH_YES; } @@ -741,18 +770,18 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) return MATCH_YES; case '/': - ch = gfc_peek_char (); + ch = gfc_peek_ascii_char (); if (ch == '=') { /* Matched "/=". */ - gfc_next_char (); + gfc_next_ascii_char (); *result = INTRINSIC_NE; return MATCH_YES; } else if (ch == '/') { /* Matched "//". */ - gfc_next_char (); + gfc_next_ascii_char (); *result = INTRINSIC_CONCAT; return MATCH_YES; } @@ -761,13 +790,13 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) return MATCH_YES; case '.': - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); switch (ch) { case 'a': - if (gfc_next_char () == 'n' - && gfc_next_char () == 'd' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 'n' + && gfc_next_ascii_char () == 'd' + && gfc_next_ascii_char () == '.') { /* Matched ".and.". */ *result = INTRINSIC_AND; @@ -776,9 +805,9 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case 'e': - if (gfc_next_char () == 'q') + if (gfc_next_ascii_char () == 'q') { - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == '.') { /* Matched ".eq.". */ @@ -787,7 +816,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) } else if (ch == 'v') { - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { /* Matched ".eqv.". */ *result = INTRINSIC_EQV; @@ -798,10 +827,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case 'g': - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == 'e') { - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { /* Matched ".ge.". */ *result = INTRINSIC_GE_OS; @@ -810,7 +839,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) } else if (ch == 't') { - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { /* Matched ".gt.". */ *result = INTRINSIC_GT_OS; @@ -820,10 +849,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case 'l': - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == 'e') { - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { /* Matched ".le.". */ *result = INTRINSIC_LE_OS; @@ -832,7 +861,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) } else if (ch == 't') { - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { /* Matched ".lt.". */ *result = INTRINSIC_LT_OS; @@ -842,10 +871,10 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case 'n': - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == 'e') { - ch = gfc_next_char (); + ch = gfc_next_ascii_char (); if (ch == '.') { /* Matched ".ne.". */ @@ -854,8 +883,8 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) } else if (ch == 'q') { - if (gfc_next_char () == 'v' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 'v' + && gfc_next_ascii_char () == '.') { /* Matched ".neqv.". */ *result = INTRINSIC_NEQV; @@ -865,8 +894,8 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) } else if (ch == 'o') { - if (gfc_next_char () == 't' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 't' + && gfc_next_ascii_char () == '.') { /* Matched ".not.". */ *result = INTRINSIC_NOT; @@ -876,8 +905,8 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result) break; case 'o': - if (gfc_next_char () == 'r' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == '.') { /* Matched ".or.". */ *result = INTRINSIC_OR; @@ -1007,7 +1036,7 @@ gfc_match_char (char c) where = gfc_current_locus; gfc_gobble_whitespace (); - if (gfc_next_char () == c) + if (gfc_next_ascii_char () == c) return MATCH_YES; gfc_current_locus = where; @@ -1157,7 +1186,7 @@ loop: } default: - if (c == gfc_next_char ()) + if (c == gfc_next_ascii_char ()) goto loop; break; } @@ -1719,6 +1748,11 @@ gfc_match_do (void) if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) return MATCH_NO; + /* Check for balanced parens. */ + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; + /* See if we have a DO WHILE. */ if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) { @@ -2414,7 +2448,6 @@ gfc_match_return (void) gfc_expr *e; match m; gfc_compile_state s; - int c; e = NULL; if (gfc_match_eos () == MATCH_YES) @@ -2433,7 +2466,7 @@ gfc_match_return (void) RETURN keyword: return+1 return(1) */ - c = gfc_peek_char (); + char c = gfc_peek_ascii_char (); if (ISALPHA (c) || ISDIGIT (c)) return MATCH_NO; } @@ -2868,12 +2901,12 @@ gfc_match_common (void) gfc_gobble_whitespace (); if (gfc_match_eos () == MATCH_YES) goto done; - if (gfc_peek_char () == '/') + if (gfc_peek_ascii_char () == '/') break; if (gfc_match_char (',') != MATCH_YES) goto syntax; gfc_gobble_whitespace (); - if (gfc_peek_char () == '/') + if (gfc_peek_ascii_char () == '/') break; } } diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 4a3776e2cd8..d46e1630136 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -38,7 +38,7 @@ extern gfc_st_label *gfc_statement_label; /* match.c. */ /* Generic match subroutines. */ -match gfc_match_special_char (int *); +match gfc_match_special_char (gfc_char_t *); match gfc_match_space (void); match gfc_match_eos (void); match gfc_match_small_literal_int (int *, int *); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 832f68698b4..f3c5316d05c 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -91,6 +91,7 @@ typedef struct int id; const char *name; int value; + int standard; } intmod_sym; @@ -1474,6 +1475,130 @@ mio_allocated_string (const char *s) } +/* Functions for quoting and unquoting strings. */ + +static char * +quote_string (const gfc_char_t *s, const size_t slength) +{ + const gfc_char_t *p; + char *res, *q; + size_t len = 0, i; + + /* Calculate the length we'll need: a backslash takes two ("\\"), + non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */ + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + len += 2; + else if (!gfc_wide_is_printable (*p)) + len += 10; + else + len++; + } + + q = res = gfc_getmem (len + 1); + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + *q++ = '\\', *q++ = '\\'; + else if (!gfc_wide_is_printable (*p)) + { + sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x", + (unsigned HOST_WIDE_INT) *p); + q += 10; + } + else + *q++ = (unsigned char) *p; + } + + res[len] = '\0'; + return res; +} + +static gfc_char_t * +unquote_string (const char *s) +{ + size_t len, i; + const char *p; + gfc_char_t *res; + + for (p = s, len = 0; *p; p++, len++) + { + if (*p != '\\') + continue; + + if (p[1] == '\\') + p++; + else if (p[1] == 'U') + p += 9; /* That is a "\U????????". */ + else + gfc_internal_error ("unquote_string(): got bad string"); + } + + res = gfc_get_wide_string (len + 1); + for (i = 0, p = s; i < len; i++, p++) + { + gcc_assert (*p); + + if (*p != '\\') + res[i] = (unsigned char) *p; + else if (p[1] == '\\') + { + res[i] = (unsigned char) '\\'; + p++; + } + else + { + /* We read the 8-digits hexadecimal constant that follows. */ + int j; + unsigned n; + gfc_char_t c = 0; + + gcc_assert (p[1] == 'U'); + for (j = 0; j < 8; j++) + { + c = c << 4; + gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1); + c += n; + } + + res[i] = c; + p += 9; + } + } + + res[len] = '\0'; + return res; +} + + +/* Read or write a character pointer that points to a wide string on the + heap, performing quoting/unquoting of nonprintable characters using the + form \U???????? (where each ? is a hexadecimal digit). + Length is the length of the string, only known and used in output mode. */ + +static const gfc_char_t * +mio_allocated_wide_string (const gfc_char_t *s, const size_t length) +{ + if (iomode == IO_OUTPUT) + { + char *quoted = quote_string (s, length); + write_atom (ATOM_STRING, quoted); + gfc_free (quoted); + return s; + } + else + { + gfc_char_t *unquoted; + + require_atom (ATOM_STRING); + unquoted = unquote_string (atom_string); + gfc_free (atom_string); + return unquoted; + } +} + + /* Read or write a string that is in static memory. */ static void @@ -2833,7 +2958,9 @@ mio_expr (gfc_expr **ep) case EXPR_SUBSTRING: e->value.character.string - = CONST_CAST (char *, mio_allocated_string (e->value.character.string)); + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); mio_ref_list (&e->ref); break; @@ -2868,7 +2995,9 @@ mio_expr (gfc_expr **ep) case BT_CHARACTER: mio_integer (&e->value.character.length); e->value.character.string - = CONST_CAST (char *, mio_allocated_string (e->value.character.string)); + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); break; default: @@ -4643,13 +4772,13 @@ use_iso_fortran_env_module (void) int i; intmod_sym symbol[] = { -#define NAMED_INTCST(a,b,c) { a, b, 0 }, +#define NAMED_INTCST(a,b,c,d) { a, b, 0, d }, #include "iso-fortran-env.def" #undef NAMED_INTCST - { ISOFORTRANENV_INVALID, NULL, -1234 } }; + { ISOFORTRANENV_INVALID, NULL, -1234, 0 } }; i = 0; -#define NAMED_INTCST(a,b,c) symbol[i++].value = c; +#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c; #include "iso-fortran-env.def" #undef NAMED_INTCST diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 245f7951ddc..9c0bae497bf 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -36,17 +36,17 @@ match gfc_match_omp_eos (void) { locus old_loc; - int c; + char c; old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); switch (c) { case '!': do - c = gfc_next_char (); + c = gfc_next_ascii_char (); while (c != '\n'); /* Fall through */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index b133743c739..dd072feb30e 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -100,7 +100,7 @@ decode_specification_statement (void) { gfc_statement st; locus old_locus; - int c; + char c; if (gfc_match_eos () == MATCH_YES) return ST_NONE; @@ -121,7 +121,7 @@ decode_specification_statement (void) statement, we eliminate most possibilities by peeking at the first character. */ - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); switch (c) { @@ -229,7 +229,7 @@ decode_statement (void) gfc_statement st; locus old_locus; match m; - int c; + char c; #ifdef GFC_DEBUG gfc_symbol_state (); @@ -315,7 +315,7 @@ decode_statement (void) statement, we eliminate most possibilities by peeking at the first character. */ - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); switch (c) { @@ -462,7 +462,7 @@ static gfc_statement decode_omp_directive (void) { locus old_locus; - int c; + char c; #ifdef GFC_DEBUG gfc_symbol_state (); @@ -485,7 +485,7 @@ decode_omp_directive (void) statement, we eliminate most possibilities by peeking at the first character. */ - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); switch (c) { @@ -569,31 +569,34 @@ static gfc_statement next_free (void) { match m; - int c, d, cnt, at_bol; + int i, cnt, at_bol; + char c; at_bol = gfc_at_bol (); gfc_gobble_whitespace (); - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); if (ISDIGIT (c)) { + char d; + /* Found a statement label? */ m = gfc_match_st_label (&gfc_statement_label); - d = gfc_peek_char (); + d = gfc_peek_ascii_char (); if (m != MATCH_YES || !gfc_is_whitespace (d)) { - gfc_match_small_literal_int (&c, &cnt); + gfc_match_small_literal_int (&i, &cnt); if (cnt > 5) gfc_error_now ("Too many digits in statement label at %C"); - if (c == 0) + if (i == 0) gfc_error_now ("Zero is not a valid statement label at %C"); do - c = gfc_next_char (); + c = gfc_next_ascii_char (); while (ISDIGIT(c)); if (!gfc_is_whitespace (c)) @@ -607,11 +610,11 @@ next_free (void) gfc_gobble_whitespace (); - if (at_bol && gfc_peek_char () == ';') + if (at_bol && gfc_peek_ascii_char () == ';') { gfc_error_now ("Semicolon at %C needs to be preceded by " "statement"); - gfc_next_char (); /* Eat up the semicolon. */ + gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -633,8 +636,8 @@ next_free (void) { int i; - c = gfc_next_char (); - for (i = 0; i < 5; i++, c = gfc_next_char ()) + c = gfc_next_ascii_char (); + for (i = 0; i < 5; i++, c = gfc_next_ascii_char ()) gcc_assert (c == "!$omp"[i]); gcc_assert (c == ' '); @@ -646,7 +649,7 @@ next_free (void) if (at_bol && c == ';') { gfc_error_now ("Semicolon at %C needs to be preceded by statement"); - gfc_next_char (); /* Eat up the semicolon. */ + gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -661,7 +664,7 @@ next_fixed (void) { int label, digit_flag, i; locus loc; - char c; + gfc_char_t c; if (!gfc_at_bol ()) return decode_statement (); @@ -694,7 +697,7 @@ next_fixed (void) case '7': case '8': case '9': - label = label * 10 + c - '0'; + label = label * 10 + ((unsigned char) c - '0'); label_locus = gfc_current_locus; digit_flag = 1; break; @@ -705,7 +708,7 @@ next_fixed (void) if (gfc_option.flag_openmp) { for (i = 0; i < 5; i++, c = gfc_next_char_literal (0)) - gcc_assert (TOLOWER (c) == "*$omp"[i]); + gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]); if (c != ' ' && c != '0') { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 6b7fd519d6a..be5fca094b6 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "parse.h" +#include "toplev.h" /* Matches a kind-parameter expression, which is either a named symbolic constant or a nonnegative integer constant. If @@ -95,8 +96,8 @@ get_kind (void) /* Given a character and a radix, see if the character is a valid digit in that radix. */ -static int -check_digit (int c, int radix) +int +gfc_check_digit (char c, int radix) { int r; @@ -119,7 +120,7 @@ check_digit (int c, int radix) break; default: - gfc_internal_error ("check_digit(): bad radix"); + gfc_internal_error ("gfc_check_digit(): bad radix"); } return r; @@ -135,21 +136,22 @@ static int match_digits (int signflag, int radix, char *buffer) { locus old_loc; - int length, c; + int length; + char c; length = 0; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (signflag && (c == '+' || c == '-')) { if (buffer != NULL) *buffer++ = c; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); length++; } - if (!check_digit (c, radix)) + if (!gfc_check_digit (c, radix)) return -1; length++; @@ -159,9 +161,9 @@ match_digits (int signflag, int radix, char *buffer) for (;;) { old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); - if (!check_digit (c, radix)) + if (!gfc_check_digit (c, radix)) break; if (buffer != NULL) @@ -275,10 +277,20 @@ match_hollerith_constant (gfc_expr **result) &gfc_current_locus); e->representation.string = gfc_getmem (num + 1); + for (i = 0; i < num; i++) { - e->representation.string[i] = gfc_next_char_literal (1); + gfc_char_t c = gfc_next_char_literal (1); + if (! gfc_wide_fits_in_byte (c)) + { + gfc_error ("Invalid Hollerith constant at %L contains a " + "wide character", &old_loc); + goto cleanup; + } + + e->representation.string[i] = (unsigned char) c; } + e->representation.string[num] = '\0'; e->representation.length = num; @@ -306,16 +318,16 @@ cleanup: static match match_boz_constant (gfc_expr **result) { - int post, radix, delim, length, x_hex, kind; + int radix, length, x_hex, kind; locus old_loc, start_loc; - char *buffer; + char *buffer, post, delim; gfc_expr *e; start_loc = old_loc = gfc_current_locus; gfc_gobble_whitespace (); x_hex = 0; - switch (post = gfc_next_char ()) + switch (post = gfc_next_ascii_char ()) { case 'b': radix = 2; @@ -346,7 +358,7 @@ match_boz_constant (gfc_expr **result) /* No whitespace allowed here. */ if (post == 0) - delim = gfc_next_char (); + delim = gfc_next_ascii_char (); if (delim != '\'' && delim != '\"') goto backup; @@ -366,7 +378,7 @@ match_boz_constant (gfc_expr **result) return MATCH_ERROR; } - if (gfc_next_char () != delim) + if (gfc_next_ascii_char () != delim) { gfc_error ("Illegal character in BOZ constant at %C"); return MATCH_ERROR; @@ -374,7 +386,7 @@ match_boz_constant (gfc_expr **result) if (post == 1) { - switch (gfc_next_char ()) + switch (gfc_next_ascii_char ()) { case 'b': radix = 2; @@ -403,9 +415,9 @@ match_boz_constant (gfc_expr **result) memset (buffer, '\0', length + 1); match_digits (0, radix, buffer); - gfc_next_char (); /* Eat delimiter. */ + gfc_next_ascii_char (); /* Eat delimiter. */ if (post == 1) - gfc_next_char (); /* Eat postfixed b, o, z, or x. */ + gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */ /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find "If a data-stmt-constant is a boz-literal-constant, the corresponding @@ -448,9 +460,9 @@ backup: static match match_real_constant (gfc_expr **result, int signflag) { - int kind, c, count, seen_dp, seen_digits, exp_char; + int kind, count, seen_dp, seen_digits; locus old_loc, temp_loc; - char *p, *buffer; + char *p, *buffer, c, exp_char; gfc_expr *e; bool negate; @@ -465,18 +477,18 @@ match_real_constant (gfc_expr **result, int signflag) exp_char = ' '; negate = FALSE; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (signflag && (c == '+' || c == '-')) { if (c == '-') negate = TRUE; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); } /* Scan significand. */ - for (;; c = gfc_next_char (), count++) + for (;; c = gfc_next_ascii_char (), count++) { if (c == '.') { @@ -486,11 +498,11 @@ match_real_constant (gfc_expr **result, int signflag) /* Check to see if "." goes with a following operator like ".eq.". */ temp_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (c == 'e' || c == 'd' || c == 'q') { - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (c == '.') goto done; /* Operator named .e. or .d. */ } @@ -517,12 +529,12 @@ match_real_constant (gfc_expr **result, int signflag) exp_char = c; /* Scan exponent. */ - c = gfc_next_char (); + c = gfc_next_ascii_char (); count++; if (c == '+' || c == '-') { /* optional sign */ - c = gfc_next_char (); + c = gfc_next_ascii_char (); count++; } @@ -534,7 +546,7 @@ match_real_constant (gfc_expr **result, int signflag) while (ISDIGIT (c)) { - c = gfc_next_char (); + c = gfc_next_ascii_char (); count++; } @@ -554,11 +566,11 @@ done: memset (buffer, '\0', count + 1); p = buffer; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (c == '+' || c == '-') { gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); } /* Hack for mpfr_set_str(). */ @@ -572,7 +584,7 @@ done: if (--count == 0) break; - c = gfc_next_char (); + c = gfc_next_ascii_char (); } kind = get_kind (); @@ -724,22 +736,26 @@ cleanup: return doubled delimiters on the input as a single instance of the delimiter. - Special return values are: + Special return values for "ret" argument are: -1 End of the string, as determined by the delimiter -2 Unterminated string detected Backslash codes are also expanded at this time. */ -static int -next_string_char (char delimiter) +static gfc_char_t +next_string_char (gfc_char_t delimiter, int *ret) { locus old_locus; - int c; + gfc_char_t c; c = gfc_next_char_literal (1); + *ret = 0; if (c == '\n') - return -2; + { + *ret = -2; + return 0; + } if (gfc_option.flag_backslash && c == '\\') { @@ -762,7 +778,8 @@ next_string_char (char delimiter) return c; gfc_current_locus = old_locus; - return -1; + *ret = -1; + return 0; } @@ -786,7 +803,7 @@ match_charkind_name (char *name) int len; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!ISALPHA (c)) return MATCH_NO; @@ -796,11 +813,11 @@ match_charkind_name (char *name) for (;;) { old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (c == '_') { - peek = gfc_peek_char (); + peek = gfc_peek_ascii_char (); if (peek == '\'' || peek == '\"') { @@ -834,13 +851,14 @@ match_charkind_name (char *name) static match match_string_constant (gfc_expr **result) { - char *p, name[GFC_MAX_SYMBOL_LEN + 1]; - int i, c, kind, length, delimiter, warn_ampersand; + char name[GFC_MAX_SYMBOL_LEN + 1], peek; + int i, kind, length, warn_ampersand, ret; locus old_locus, start_locus; gfc_symbol *sym; gfc_expr *e; const char *q; match m; + gfc_char_t c, delimiter, *p; old_locus = gfc_current_locus; @@ -855,11 +873,11 @@ match_string_constant (gfc_expr **result) goto got_delim; } - if (ISDIGIT (c)) + if (gfc_wide_is_digit (c)) { kind = 0; - while (ISDIGIT (c)) + while (gfc_wide_is_digit (c)) { kind = kind * 10 + c - '0'; if (kind > 9999999) @@ -929,10 +947,10 @@ got_delim: for (;;) { - c = next_string_char (delimiter); - if (c == -1) + c = next_string_char (delimiter, &ret); + if (ret == -1) break; - if (c == -2) + if (ret == -2) { gfc_current_locus = start_locus; gfc_error ("Unterminated character constant beginning at %C"); @@ -944,8 +962,8 @@ got_delim: /* Peek at the next character to see if it is a b, o, z, or x for the postfixed BOZ literal constants. */ - c = gfc_peek_char (); - if (c == 'b' || c == 'o' || c =='z' || c == 'x') + peek = gfc_peek_ascii_char (); + if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x') goto no_match; @@ -959,7 +977,7 @@ got_delim: e->ts.is_iso_c = 0; e->where = start_locus; - e->value.character.string = p = gfc_getmem (length + 1); + e->value.character.string = p = gfc_get_wide_string (length + 1); e->value.character.length = length; gfc_current_locus = start_locus; @@ -971,12 +989,24 @@ got_delim: gfc_option.warn_ampersand = 0; for (i = 0; i < length; i++) - *p++ = next_string_char (delimiter); + { + c = next_string_char (delimiter, &ret); + + if (!gfc_wide_fits_in_byte (c)) + { + gfc_error ("Unimplemented feature at %C: gfortran currently only " + "supports character strings with one-byte characters"); + return MATCH_ERROR; + } + + *p++ = c; + } *p = '\0'; /* TODO: C-style string is for development/debug purposes. */ gfc_option.warn_ampersand = warn_ampersand; - if (next_string_char (delimiter) != -1) + next_string_char (delimiter, &ret); + if (ret != -1) gfc_internal_error ("match_string_constant(): Delimiter not found"); if (match_substring (NULL, 0, &e->ref) != MATCH_NO) @@ -1000,25 +1030,25 @@ match_logical_constant_string (void) locus orig_loc = gfc_current_locus; gfc_gobble_whitespace (); - if (gfc_next_char () == '.') + if (gfc_next_ascii_char () == '.') { - int ch = gfc_next_char(); + char ch = gfc_next_ascii_char (); if (ch == 'f') { - if (gfc_next_char () == 'a' - && gfc_next_char () == 'l' - && gfc_next_char () == 's' - && gfc_next_char () == 'e' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 'a' + && gfc_next_ascii_char () == 'l' + && gfc_next_ascii_char () == 's' + && gfc_next_ascii_char () == 'e' + && gfc_next_ascii_char () == '.') /* Matched ".false.". */ return 0; } else if (ch == 't') { - if (gfc_next_char () == 'r' - && gfc_next_char () == 'u' - && gfc_next_char () == 'e' - && gfc_next_char () == '.') + if (gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == 'u' + && gfc_next_ascii_char () == 'e' + && gfc_next_ascii_char () == '.') /* Matched ".true.". */ return 1; } @@ -1214,7 +1244,7 @@ match_complex_constant (gfc_expr **result) { /* Give the matcher for implied do-loops a chance to run. This yields a much saner error message for (/ (i, 4=i, 6) /). */ - if (gfc_peek_char () == '=') + if (gfc_peek_ascii_char () == '=') { m = MATCH_ERROR; goto cleanup; @@ -1328,7 +1358,7 @@ match_actual_arg (gfc_expr **result) gfc_symtree *symtree; locus where, w; gfc_expr *e; - int c; + char c; where = gfc_current_locus; @@ -1343,7 +1373,7 @@ match_actual_arg (gfc_expr **result) case MATCH_YES: w = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); gfc_current_locus = w; if (c != ',' && c != ')') @@ -1684,7 +1714,7 @@ match_varspec (gfc_expr *primary, int equiv_flag) tail = NULL; gfc_gobble_whitespace (); - if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension) + if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension) { /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -1698,7 +1728,7 @@ match_varspec (gfc_expr *primary, int equiv_flag) return m; gfc_gobble_whitespace (); - if (equiv_flag && gfc_peek_char () == '(') + if (equiv_flag && gfc_peek_ascii_char () == '(') { tail = extend_ref (primary, tail); tail->type = REF_ARRAY; @@ -1936,17 +1966,39 @@ gfc_expr_attr (gfc_expr *e) /* Match a structure constructor. The initial symbol has already been seen. */ +typedef struct gfc_structure_ctor_component +{ + char* name; + gfc_expr* val; + locus where; + struct gfc_structure_ctor_component* next; +} +gfc_structure_ctor_component; + +#define gfc_get_structure_ctor_component() \ + gfc_getmem(sizeof(gfc_structure_ctor_component)) + +static void +gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) +{ + gfc_free (comp->name); + gfc_free_expr (comp->val); +} + match gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) { - gfc_constructor *head, *tail; - gfc_component *comp; + gfc_structure_ctor_component *comp_head, *comp_tail; + gfc_structure_ctor_component *comp_iter; + gfc_constructor *ctor_head, *ctor_tail; + gfc_component *comp; /* Is set NULL when named component is first seen */ gfc_expr *e; locus where; match m; - bool private_comp = false; + const char* last_name = NULL; - head = tail = NULL; + comp_head = comp_tail = NULL; + ctor_head = ctor_tail = NULL; if (gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -1955,58 +2007,195 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) gfc_find_component (sym, NULL); - for (comp = sym->components; comp; comp = comp->next) + /* Match the component list and store it in a list together with the + corresponding component names. Check for empty argument list first. */ + if (gfc_match_char (')') != MATCH_YES) { - if (comp->access == ACCESS_PRIVATE) + comp = sym->components; + do { - private_comp = true; - break; - } - if (head == NULL) - tail = head = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + gfc_component *this_comp = NULL; - m = gfc_match_expr (&tail->expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + if (!comp_head) + comp_tail = comp_head = gfc_get_structure_ctor_component (); + else + { + comp_tail->next = gfc_get_structure_ctor_component (); + comp_tail = comp_tail->next; + } + comp_tail->name = gfc_getmem(GFC_MAX_SYMBOL_LEN + 1); + comp_tail->val = NULL; + comp_tail->where = gfc_current_locus; - if (gfc_match_char (',') == MATCH_YES) - { - if (comp->next == NULL) + /* Try matching a component name. */ + if (gfc_match_name (comp_tail->name) == MATCH_YES + && gfc_match_char ('=') == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" + " constructor with named arguments at %C") + == FAILURE) + goto cleanup; + + last_name = comp_tail->name; + comp = NULL; + } + else + { + /* Components without name are not allowed after the first named + component initializer! */ + if (!comp) + { + if (last_name) + gfc_error ("Component initializer without name after" + " component named %s at %C!", last_name); + else + gfc_error ("Too many components in structure constructor at" + " %C!"); + goto cleanup; + } + + gfc_current_locus = comp_tail->where; + strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1); + } + + /* Find the current component in the structure definition; this is + needed to get its access attribute in the private check below. */ + if (comp) + this_comp = comp; + else + { + for (comp = sym->components; comp; comp = comp->next) + if (!strcmp (comp->name, comp_tail->name)) + { + this_comp = comp; + break; + } + comp = NULL; /* Reset needed! */ + + /* Here we can check if a component name is given which does not + correspond to any component of the defined structure. */ + if (!this_comp) + { + gfc_error ("Component '%s' in structure constructor at %C" + " does not correspond to any component in the" + " constructed structure!", comp_tail->name); + goto cleanup; + } + } + gcc_assert (this_comp); + + /* Check the current component's access status. */ + if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE) { - gfc_error ("Too many components in structure constructor at %C"); + gfc_error ("Component '%s' is PRIVATE in structure constructor" + " at %C!", comp_tail->name); goto cleanup; } - continue; + /* Check if this component is already given a value. */ + for (comp_iter = comp_head; comp_iter != comp_tail; + comp_iter = comp_iter->next) + { + gcc_assert (comp_iter); + if (!strcmp (comp_iter->name, comp_tail->name)) + { + gfc_error ("Component '%s' is initialized twice in the" + " structure constructor at %C!", comp_tail->name); + goto cleanup; + } + } + + /* Match the current initializer expression. */ + m = gfc_match_expr (&comp_tail->val); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (comp) + comp = comp->next; } + while (gfc_match_char (',') == MATCH_YES); - break; + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + /* If there were components given and all components are private, error + out at this place. */ + if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE) + { + gfc_error ("All components of '%s' are PRIVATE in structure" + " constructor at %C", sym->name); + goto cleanup; + } } - if (sym->attr.use_assoc - && (sym->component_access == ACCESS_PRIVATE || private_comp)) + /* Translate the component list into the actual constructor by sorting it in + the order required; this also checks along the way that each and every + component actually has an initializer and handles default initializers + for components without explicit value given. */ + for (comp = sym->components; comp; comp = comp->next) { - gfc_error ("Structure constructor for '%s' at %C has PRIVATE " - "components", sym->name); - goto cleanup; - } + gfc_structure_ctor_component **next_ptr; + gfc_expr *value = NULL; - if (gfc_match_char (')') != MATCH_YES) - goto syntax; + /* Try to find the initializer for the current component by name. */ + next_ptr = &comp_head; + for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next) + { + if (!strcmp (comp_iter->name, comp->name)) + break; + next_ptr = &comp_iter->next; + } - if (comp && comp->next != NULL) - { - gfc_error ("Too few components in structure constructor at %C"); - goto cleanup; + /* If it was not found, try the default initializer if there's any; + otherwise, it's an error. */ + if (!comp_iter) + { + if (comp->initializer) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" + " constructor with missing optional arguments" + " at %C") == FAILURE) + goto cleanup; + value = gfc_copy_expr (comp->initializer); + } + else + { + gfc_error ("No initializer for component '%s' given in the" + " structure constructor at %C!", comp->name); + goto cleanup; + } + } + else + value = comp_iter->val; + + /* Add the value to the constructor chain built. */ + if (ctor_tail) + { + ctor_tail->next = gfc_get_constructor (); + ctor_tail = ctor_tail->next; + } + else + ctor_head = ctor_tail = gfc_get_constructor (); + gcc_assert (value); + ctor_tail->expr = value; + + /* Remove the entry from the component list. We don't want the expression + value to be free'd, so set it to NULL. */ + if (comp_iter) + { + *next_ptr = comp_iter->next; + comp_iter->val = NULL; + gfc_free_structure_ctor_component (comp_iter); + } } + /* No component should be left, as this should have caused an error in the + loop constructing the component-list (name that does not correspond to any + component in the structure definition). */ + gcc_assert (!comp_head); + e = gfc_get_expr (); e->expr_type = EXPR_STRUCTURE; @@ -2015,7 +2204,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) e->ts.derived = sym; e->where = where; - e->value.constructor = head; + e->value.constructor = ctor_head; *result = e; return MATCH_YES; @@ -2024,7 +2213,13 @@ syntax: gfc_error ("Syntax error in structure constructor at %C"); cleanup: - gfc_free_constructor (head); + for (comp_iter = comp_head; comp_iter; ) + { + gfc_structure_ctor_component *next = comp_iter->next; + gfc_free_structure_ctor_component (comp_iter); + comp_iter = next; + } + gfc_free_constructor (ctor_head); return MATCH_ERROR; } @@ -2101,7 +2296,7 @@ gfc_match_rvalue (gfc_expr **result) /* See if this is a directly recursive function call. */ gfc_gobble_whitespace (); if (sym->attr.recursive - && gfc_peek_char () == '(' + && gfc_peek_ascii_char () == '(' && gfc_current_ns->proc_name == sym && !sym->attr.dimension) { @@ -2139,7 +2334,7 @@ gfc_match_rvalue (gfc_expr **result) { case FL_VARIABLE: variable: - if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%' + if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%' && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); @@ -2304,7 +2499,7 @@ gfc_match_rvalue (gfc_expr **result) via an IMPLICIT statement. This can't wait for the resolution phase. */ - if (gfc_peek_char () == '%' + if (gfc_peek_ascii_char () == '%' && sym->ts.type == BT_UNKNOWN && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); @@ -2333,7 +2528,7 @@ gfc_match_rvalue (gfc_expr **result) variable is just a scalar. */ gfc_gobble_whitespace (); - if (gfc_peek_char () != '(') + if (gfc_peek_ascii_char () != '(') { /* Assume a scalar variable */ e = gfc_get_expr (); @@ -2545,7 +2740,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) break; /* These are definitive indicators that this is a variable. */ - else if (gfc_peek_char () != '(' || sym->ts.type != BT_UNKNOWN + else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN || sym->attr.pointer || sym->as != NULL) flavor = FL_VARIABLE; @@ -2605,7 +2800,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) else implicit_ns = sym->ns; - if (gfc_peek_char () == '%' + if (gfc_peek_ascii_char () == '%' && sym->ts.type == BT_UNKNOWN && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, implicit_ns); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 424420583ed..bf886240061 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3510,8 +3510,8 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) { - gfc_error ("Array index at %L must be of INTEGER type", - &index->where); + gfc_error ("Array index at %L must be of INTEGER type, found %s", + &index->where, gfc_basic_typename (index->ts.type)); return FAILURE; } @@ -6804,7 +6804,6 @@ build_default_init_expr (gfc_symbol *sym) int char_len; gfc_expr *init_expr; int i; - char *ch; /* These symbols should never have a default initialization. */ if ((sym->attr.dimension && !gfc_is_compile_time_shape (sym->as)) @@ -6922,10 +6921,10 @@ build_default_init_expr (gfc_symbol *sym) { char_len = mpz_get_si (sym->ts.cl->length->value.integer); init_expr->value.character.length = char_len; - init_expr->value.character.string = gfc_getmem (char_len+1); - ch = init_expr->value.character.string; + init_expr->value.character.string = gfc_get_wide_string (char_len+1); for (i = 0; i < char_len; i++) - *(ch++) = gfc_option.flag_init_character_value; + init_expr->value.character.string[i] + = (unsigned char) gfc_option.flag_init_character_value; } else { diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 1aa52f5d576..13e06155283 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -72,7 +72,7 @@ static gfc_linebuf *line_head, *line_tail; locus gfc_current_locus; const char *gfc_source_file; static FILE *gfc_src_file; -static char *gfc_src_preprocessor_lines[2]; +static gfc_char_t *gfc_src_preprocessor_lines[2]; extern int pedantic; @@ -85,6 +85,182 @@ static struct gfc_file_change size_t file_changes_cur, file_changes_count; size_t file_changes_allocated; + +/* Functions dealing with our wide characters (gfc_char_t) and + sequences of such characters. */ + +int +gfc_wide_fits_in_byte (gfc_char_t c) +{ + return (c <= UCHAR_MAX); +} + +static inline int +wide_is_ascii (gfc_char_t c) +{ + return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0); +} + +int +gfc_wide_is_printable (gfc_char_t c) +{ + return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c)); +} + +gfc_char_t +gfc_wide_tolower (gfc_char_t c) +{ + return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c); +} + +gfc_char_t +gfc_wide_toupper (gfc_char_t c) +{ + return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c); +} + +int +gfc_wide_is_digit (gfc_char_t c) +{ + return (c >= '0' && c <= '9'); +} + +static inline int +wide_atoi (gfc_char_t *c) +{ +#define MAX_DIGITS 20 + char buf[MAX_DIGITS+1]; + int i = 0; + + while (gfc_wide_is_digit(*c) && i < MAX_DIGITS) + buf[i++] = *c++; + buf[i] = '\0'; + return atoi (buf); +} + +size_t +gfc_wide_strlen (const gfc_char_t *str) +{ + size_t i; + + for (i = 0; str[i]; i++) + ; + + return i; +} + +gfc_char_t * +gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len) +{ + size_t i; + + for (i = 0; i < len; i++) + b[i] = c; + + return b; +} + +static gfc_char_t * +wide_strcpy (gfc_char_t *dest, const gfc_char_t *src) +{ + gfc_char_t *d; + + for (d = dest; (*d = *src) != '\0'; ++src, ++d) + ; + + return dest; +} + +static gfc_char_t * +wide_strchr (const gfc_char_t *s, gfc_char_t c) +{ + do { + if (*s == c) + { + return CONST_CAST(gfc_char_t *, s); + } + } while (*s++); + return 0; +} + +char * +gfc_widechar_to_char (const gfc_char_t *s, int length) +{ + size_t len, i; + char *res; + + if (s == NULL) + return NULL; + + /* Passing a negative length is used to indicate that length should be + calculated using gfc_wide_strlen(). */ + len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s)); + res = gfc_getmem (len + 1); + + for (i = 0; i < len; i++) + { + gcc_assert (gfc_wide_fits_in_byte (s[i])); + res[i] = (unsigned char) s[i]; + } + + res[len] = '\0'; + return res; +} + +gfc_char_t * +gfc_char_to_widechar (const char *s) +{ + size_t len, i; + gfc_char_t *res; + + if (s == NULL) + return NULL; + + len = strlen (s); + res = gfc_get_wide_string (len + 1); + + for (i = 0; i < len; i++) + res[i] = (unsigned char) s[i]; + + res[len] = '\0'; + return res; +} + +static int +wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n) +{ + gfc_char_t c1, c2; + + while (n-- > 0) + { + c1 = *s1++; + c2 = *s2++; + if (c1 != c2) + return (c1 > c2 ? 1 : -1); + if (c1 == '\0') + return 0; + } + return 0; +} + +int +gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n) +{ + gfc_char_t c1, c2; + + while (n-- > 0) + { + c1 = gfc_wide_tolower (*s1++); + c2 = TOLOWER (*s2++); + if (c1 != c2) + return (c1 > c2 ? 1 : -1); + if (c1 == '\0') + return 0; + } + return 0; +} + + /* Main scanner initialization. */ void @@ -406,15 +582,15 @@ gfc_advance_line (void) pointer from being on the wrong line if the current statement ends prematurely. */ -static int +static gfc_char_t next_char (void) { - int c; + gfc_char_t c; if (gfc_current_locus.nextc == NULL) return '\n'; - c = (unsigned char) *gfc_current_locus.nextc++; + c = *gfc_current_locus.nextc++; if (c == '\0') { gfc_current_locus.nextc--; /* Remain on this line. */ @@ -433,7 +609,7 @@ next_char (void) static void skip_comment_line (void) { - char c; + gfc_char_t c; do { @@ -448,17 +624,27 @@ skip_comment_line (void) int gfc_define_undef_line (void) { + char *tmp; + /* All lines beginning with '#' are either #define or #undef. */ - if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_char () != '#') + if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#') return 0; - if (strncmp (gfc_current_locus.nextc, "#define ", 8) == 0) - (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb), - &(gfc_current_locus.nextc[8])); + if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0) + { + tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1); + (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb), + tmp); + gfc_free (tmp); + } - if (strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0) - (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb), - &(gfc_current_locus.nextc[7])); + if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0) + { + tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1); + (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb), + tmp); + gfc_free (tmp); + } /* Skip the rest of the line. */ skip_comment_line (); @@ -476,7 +662,7 @@ static bool skip_free_comments (void) { locus start; - char c; + gfc_char_t c; int at_bol; for (;;) @@ -570,7 +756,7 @@ skip_fixed_comments (void) { locus start; int col; - char c; + gfc_char_t c; if (! gfc_at_bol ()) { @@ -738,11 +924,12 @@ gfc_skip_comments (void) line. The in_string flag denotes whether we're inside a character context or not. */ -int +gfc_char_t gfc_next_char_literal (int in_string) { locus old_loc; - int i, c, prev_openmp_flag; + int i, prev_openmp_flag; + gfc_char_t c; continue_flag = 0; @@ -859,7 +1046,7 @@ restart: { for (i = 0; i < 5; i++, c = next_char ()) { - gcc_assert (TOLOWER (c) == "!$omp"[i]); + gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]); if (i == 4) old_loc = gfc_current_locus; } @@ -932,7 +1119,7 @@ restart: for (i = 0; i < 5; i++) { c = next_char (); - if (TOLOWER (c) != "*$omp"[i]) + if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i]) goto not_continuation; } @@ -980,10 +1167,10 @@ done: parsing character literals, they have to call gfc_next_char_literal(). */ -int +gfc_char_t gfc_next_char (void) { - int c; + gfc_char_t c; do { @@ -991,15 +1178,24 @@ gfc_next_char (void) } while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c)); - return TOLOWER (c); + return gfc_wide_tolower (c); } +char +gfc_next_ascii_char (void) +{ + gfc_char_t c = gfc_next_char (); -int + return (gfc_wide_fits_in_byte (c) ? (unsigned char) c + : (unsigned char) UCHAR_MAX); +} + + +gfc_char_t gfc_peek_char (void) { locus old_loc; - int c; + gfc_char_t c; old_loc = gfc_current_locus; c = gfc_next_char (); @@ -1009,6 +1205,16 @@ gfc_peek_char (void) } +char +gfc_peek_ascii_char (void) +{ + gfc_char_t c = gfc_peek_char (); + + return (gfc_wide_fits_in_byte (c) ? (unsigned char) c + : (unsigned char) UCHAR_MAX); +} + + /* Recover from an error. We try to get past the current statement and get lined up for the next. The next statement follows a '\n' or a ';'. We also assume that we are not within a character @@ -1017,7 +1223,7 @@ gfc_peek_char (void) void gfc_error_recovery (void) { - char c, delim; + gfc_char_t c, delim; if (gfc_at_eof ()) return; @@ -1064,7 +1270,7 @@ gfc_gobble_whitespace (void) { static int linenum = 0; locus old_loc; - int c; + gfc_char_t c; do { @@ -1106,13 +1312,13 @@ gfc_gobble_whitespace (void) parts of gfortran. */ static int -load_line (FILE *input, char **pbuf, int *pbuflen) +load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen) { static int linenum = 0, current_line = 1; int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; int trunc_flag = 0, seen_comment = 0; int seen_printable = 0, seen_ampersand = 0; - char *buffer; + gfc_char_t *buffer; bool found_tab = false; /* Determine the maximum allowed line length. */ @@ -1135,7 +1341,7 @@ load_line (FILE *input, char **pbuf, int *pbuflen) else buflen = 132; - *pbuf = gfc_getmem (buflen + 1); + *pbuf = gfc_get_wide_string (buflen + 1); } i = 0; @@ -1234,7 +1440,7 @@ load_line (FILE *input, char **pbuf, int *pbuflen) /* Reallocate line buffer to double size to hold the overlong line. */ buflen = buflen * 2; - *pbuf = xrealloc (*pbuf, buflen + 1); + *pbuf = xrealloc (*pbuf, (buflen + 1) * sizeof (gfc_char_t)); buffer = (*pbuf) + i; } } @@ -1297,17 +1503,19 @@ get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED) return f; } + /* Deal with a line from the C preprocessor. The initial octothorp has already been seen. */ static void -preprocessor_line (char *c) +preprocessor_line (gfc_char_t *c) { bool flag[5]; int i, line; - char *filename; + gfc_char_t *wide_filename; gfc_file *f; int escaped, unescape; + char *filename; c++; while (*c == ' ' || *c == '\t') @@ -1316,9 +1524,9 @@ preprocessor_line (char *c) if (*c < '0' || *c > '9') goto bad_cpp_line; - line = atoi (c); + line = wide_atoi (c); - c = strchr (c, ' '); + c = wide_strchr (c, ' '); if (c == NULL) { /* No file name given. Set new line number. */ @@ -1335,7 +1543,7 @@ preprocessor_line (char *c) goto bad_cpp_line; ++c; - filename = c; + wide_filename = c; /* Make filename end at quote. */ unescape = 0; @@ -1361,10 +1569,10 @@ preprocessor_line (char *c) /* Undo effects of cpp_quote_string. */ if (unescape) { - char *s = filename; - char *d = gfc_getmem (c - filename - unescape); + gfc_char_t *s = wide_filename; + gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape); - filename = d; + wide_filename = d; while (*s) { if (*s == '\\') @@ -1382,17 +1590,21 @@ preprocessor_line (char *c) for (;;) { - c = strchr (c, ' '); + c = wide_strchr (c, ' '); if (c == NULL) break; c++; - i = atoi (c); + i = wide_atoi (c); if (1 <= i && i <= 4) flag[i] = true; } + /* Convert the filename in wide characters into a filename in narrow + characters. */ + filename = gfc_widechar_to_char (wide_filename, -1); + /* Interpret flags. */ if (flag[1]) /* Starting new file. */ @@ -1411,7 +1623,8 @@ preprocessor_line (char *c) current_file->filename, current_file->line, filename); if (unescape) - gfc_free (filename); + gfc_free (wide_filename); + gfc_free (filename); return; } @@ -1434,7 +1647,8 @@ preprocessor_line (char *c) /* Set new line number. */ current_file->line = line; if (unescape) - gfc_free (filename); + gfc_free (wide_filename); + gfc_free (filename); return; bad_cpp_line: @@ -1453,9 +1667,10 @@ static try load_file (const char *, bool); processed or true if we matched an include. */ static bool -include_line (char *line) +include_line (gfc_char_t *line) { - char quote, *c, *begin, *stop; + gfc_char_t quote, *c, *begin, *stop; + char *filename; c = line; @@ -1479,8 +1694,8 @@ include_line (char *line) while (*c == ' ' || *c == '\t') c++; - if (strncasecmp (c, "include", 7)) - return false; + if (gfc_wide_strncasecmp (c, "include", 7)) + return false; c += 7; while (*c == ' ' || *c == '\t') @@ -1513,7 +1728,9 @@ include_line (char *line) *stop = '\0'; /* It's ok to trash the buffer, as this line won't be read by anything else. */ - load_file (begin, false); + filename = gfc_widechar_to_char (begin, -1); + load_file (filename, false); + gfc_free (filename); return true; } @@ -1523,7 +1740,7 @@ include_line (char *line) static try load_file (const char *filename, bool initial) { - char *line; + gfc_char_t *line; gfc_linebuf *b; gfc_file *f; FILE *input; @@ -1590,7 +1807,7 @@ load_file (const char *filename, bool initial) { int trunc = load_line (input, &line, &line_len); - len = strlen (line); + len = gfc_wide_strlen (line); if (feof (input) && len == 0) break; @@ -1600,15 +1817,18 @@ load_file (const char *filename, bool initial) FE FF is UTF-16 big endian, EF BB BF is UTF-8. */ if (first_line - && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE') - || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF') - || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB' - && line[2] == '\xBF'))) + && ((line_len >= 2 && line[0] == (unsigned char) '\xFF' + && line[1] == (unsigned char) '\xFE') + || (line_len >= 2 && line[0] == (unsigned char) '\xFE' + && line[1] == (unsigned char) '\xFF') + || (line_len >= 3 && line[0] == (unsigned char) '\xEF' + && line[1] == (unsigned char) '\xBB' + && line[2] == (unsigned char) '\xBF'))) { - int n = line[1] == '\xBB' ? 3 : 2; - char * new = gfc_getmem (line_len); + int n = line[1] == (unsigned char) '\xBB' ? 3 : 2; + gfc_char_t *new = gfc_get_wide_string (line_len); - strcpy (new, line + n); + wide_strcpy (new, &line[n]); gfc_free (line); line = new; len -= n; @@ -1623,8 +1843,8 @@ load_file (const char *filename, bool initial) and #undef lines, which we need to pass to the middle-end so that it can emit correct debug info. */ if (debug_info_level == DINFO_LEVEL_VERBOSE - && (strncmp (line, "#define ", 8) == 0 - || strncmp (line, "#undef ", 7) == 0)) + && (wide_strncmp (line, "#define ", 8) == 0 + || wide_strncmp (line, "#undef ", 7) == 0)) ; else { @@ -1646,13 +1866,14 @@ load_file (const char *filename, bool initial) /* Add line. */ - b = gfc_getmem (gfc_linebuf_header_size + len + 1); + b = gfc_getmem (gfc_linebuf_header_size + + (len + 1) * sizeof (gfc_char_t)); b->location = linemap_line_start (line_table, current_file->line++, 120); b->file = current_file; b->truncated = trunc; - strcpy (b->line, line); + wide_strcpy (b->line, line); if (line_head == NULL) line_head = b; @@ -1752,7 +1973,7 @@ const char * gfc_read_orig_filename (const char *filename, const char **canon_source_file) { int c, len; - char *dirname; + char *dirname, *tmp; gfc_src_file = gfc_open_file (filename); if (gfc_src_file == NULL) @@ -1767,10 +1988,12 @@ gfc_read_orig_filename (const char *filename, const char **canon_source_file) len = 0; load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len); - if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0) + if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0) return NULL; - filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5); + tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1); + filename = unescape_filename (tmp); + gfc_free (tmp); if (filename == NULL) return NULL; @@ -1783,10 +2006,12 @@ gfc_read_orig_filename (const char *filename, const char **canon_source_file) len = 0; load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len); - if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0) + if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0) return filename; - dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5); + tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1); + dirname = unescape_filename (tmp); + gfc_free (tmp); if (dirname == NULL) return filename; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index cde4770a1ec..4159374f06e 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -284,7 +284,7 @@ gfc_simplify_achar (gfc_expr *e, gfc_expr *k) result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - result->value.character.string = gfc_getmem (2); + result->value.character.string = gfc_get_wide_string (2); result->value.character.length = 1; result->value.character.string[0] = c; @@ -343,7 +343,7 @@ gfc_simplify_adjustl (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -353,7 +353,7 @@ gfc_simplify_adjustl (gfc_expr *e) result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); result->value.character.length = len; - result->value.character.string = gfc_getmem (len + 1); + result->value.character.string = gfc_get_wide_string (len + 1); for (count = 0, i = 0; i < len; ++i) { @@ -380,7 +380,7 @@ gfc_simplify_adjustr (gfc_expr *e) { gfc_expr *result; int count, i, len; - char ch; + gfc_char_t ch; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -390,7 +390,7 @@ gfc_simplify_adjustr (gfc_expr *e) result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); result->value.character.length = len; - result->value.character.string = gfc_getmem (len + 1); + result->value.character.string = gfc_get_wide_string (len + 1); for (count = 0, i = len - 1; i >= 0; --i) { @@ -505,14 +505,15 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) { result = gfc_constant_result (BT_INTEGER, kind, &x->where); mpz_and (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "AND"); } else /* BT_LOGICAL */ { result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result->value.logical = x->value.logical && y->value.logical; + return result; } - return range_check (result, "AND"); } @@ -637,6 +638,132 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) gfc_expr * +gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J0"); +#else + return NULL; +#endif +} + + +gfc_expr * +gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J1"); +#else + return NULL; +#endif +} + + +gfc_expr * +gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, + gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_JN"); +#else + return NULL; +#endif +} + + +gfc_expr * +gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y0"); +#else + return NULL; +#endif +} + + +gfc_expr * +gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y1"); +#else + return NULL; +#endif +} + + +gfc_expr * +gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, + gfc_expr *x ATTRIBUTE_UNUSED) +{ +#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + gfc_set_model_kind (x->ts.kind); + mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_YN"); +#else + return NULL; +#endif +} + + +gfc_expr * gfc_simplify_bit_size (gfc_expr *e) { gfc_expr *result; @@ -717,7 +844,7 @@ gfc_simplify_char (gfc_expr *e, gfc_expr *k) result = gfc_constant_result (BT_CHARACTER, kind, &e->where); result->value.character.length = 1; - result->value.character.string = gfc_getmem (2); + result->value.character.string = gfc_get_wide_string (2); result->value.character.string[0] = c; result->value.character.string[1] = '\0'; /* For debugger */ @@ -802,19 +929,49 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) } +/* Function called when we won't simplify an expression like CMPLX (or + COMPLEX or DCMPLX) but still want to convert BOZ arguments. */ + +static gfc_expr * +only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind) +{ + if (x->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = kind; + if (!gfc_convert_boz (x, &ts)) + return &gfc_bad_expr; + } + + if (y && y->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = kind; + if (!gfc_convert_boz (y, &ts)) + return &gfc_bad_expr; + } + + return NULL; +} + + gfc_expr * gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) { int kind; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind); if (kind == -1) return &gfc_bad_expr; + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return only_convert_cmplx_boz (x, y, kind); + return simplify_cmplx ("CMPLX", x, y, kind); } @@ -824,10 +981,6 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) { int kind; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - if (x->ts.type == BT_INTEGER) { if (y->ts.type == BT_INTEGER) @@ -843,6 +996,10 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) kind = x->ts.kind; } + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return only_convert_cmplx_boz (x, y, kind); + return simplify_cmplx ("COMPLEX", x, y, kind); } @@ -926,7 +1083,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; + return only_convert_cmplx_boz (x, y, gfc_default_double_kind); return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); } @@ -967,7 +1124,10 @@ gfc_simplify_dble (gfc_expr *e) ts.kind = gfc_default_double_kind; result = gfc_copy_expr (e); if (!gfc_convert_boz (result, &ts)) - return &gfc_bad_expr; + { + gfc_free_expr (result); + return &gfc_bad_expr; + } } return range_check (result, "DBLE"); @@ -1190,7 +1350,10 @@ gfc_simplify_float (gfc_expr *a) result = gfc_copy_expr (a); if (!gfc_convert_boz (result, &ts)) - return &gfc_bad_expr; + { + gfc_free_expr (result); + return &gfc_bad_expr; + } } else result = gfc_int2real (a, gfc_default_real_kind); @@ -1334,7 +1497,7 @@ gfc_expr * gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int index; + gfc_char_t index; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -1345,7 +1508,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) return &gfc_bad_expr; } - index = (unsigned char) e->value.character.string[0]; + index = e->value.character.string[0]; if (gfc_option.warn_surprising && index > 127) gfc_warning ("Argument of IACHAR function at %L outside of range 0..127", @@ -1523,7 +1686,7 @@ gfc_expr * gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int index; + gfc_char_t index; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -1534,9 +1697,8 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) return &gfc_bad_expr; } - index = (unsigned char) e->value.character.string[0]; - - if (index < 0 || index > UCHAR_MAX) + index = e->value.character.string[0]; + if (index > UCHAR_MAX) gfc_internal_error("Argument of ICHAR at %L out of range", &e->where); if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL) @@ -1711,7 +1873,7 @@ done: gfc_expr * gfc_simplify_int (gfc_expr *e, gfc_expr *k) { - gfc_expr *rpart, *rtrunc, *result; + gfc_expr *result = NULL; int kind; kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); @@ -1721,33 +1883,22 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - switch (e->ts.type) { case BT_INTEGER: - mpz_set (result->value.integer, e->value.integer); + result = gfc_int2int (e, kind); break; case BT_REAL: - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rtrunc); + result = gfc_real2int (e, kind); break; case BT_COMPLEX: - rpart = gfc_complex2real (e, kind); - rtrunc = gfc_copy_expr (rpart); - mpfr_trunc (rtrunc->value.real, rpart->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rpart); - gfc_free_expr (rtrunc); + result = gfc_complex2int (e, kind); break; default: gfc_error ("Argument of INT at %L is not a valid type", &e->where); - gfc_free_expr (result); return &gfc_bad_expr; } @@ -1756,40 +1907,29 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k) static gfc_expr * -gfc_simplify_intconv (gfc_expr *e, int kind, const char *name) +simplify_intconv (gfc_expr *e, int kind, const char *name) { - gfc_expr *rpart, *rtrunc, *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - switch (e->ts.type) { case BT_INTEGER: - mpz_set (result->value.integer, e->value.integer); + result = gfc_int2int (e, kind); break; case BT_REAL: - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rtrunc); + result = gfc_real2int (e, kind); break; case BT_COMPLEX: - rpart = gfc_complex2real (e, kind); - rtrunc = gfc_copy_expr (rpart); - mpfr_trunc (rtrunc->value.real, rpart->value.real); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real); - gfc_free_expr (rpart); - gfc_free_expr (rtrunc); + result = gfc_complex2int (e, kind); break; default: gfc_error ("Argument of %s at %L is not a valid type", name, &e->where); - gfc_free_expr (result); return &gfc_bad_expr; } @@ -1800,21 +1940,21 @@ gfc_simplify_intconv (gfc_expr *e, int kind, const char *name) gfc_expr * gfc_simplify_int2 (gfc_expr *e) { - return gfc_simplify_intconv (e, 2, "INT2"); + return simplify_intconv (e, 2, "INT2"); } gfc_expr * gfc_simplify_int8 (gfc_expr *e) { - return gfc_simplify_intconv (e, 8, "INT8"); + return simplify_intconv (e, 8, "INT8"); } gfc_expr * gfc_simplify_long (gfc_expr *e) { - return gfc_simplify_intconv (e, 4, "LONG"); + return simplify_intconv (e, 4, "LONG"); } @@ -2223,7 +2363,10 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", gfc_default_integer_kind); if (k == -1) - return &gfc_bad_expr; + { + gfc_free_expr (e); + return &gfc_bad_expr; + } e->ts.kind = k; /* The result is a rank 1 array; its size is the rank of the first @@ -2337,7 +2480,7 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) } gfc_expr * -gfc_simplify_lgamma (gfc_expr *x __attribute__((unused))) +gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) { #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0) gfc_expr *result; @@ -2561,12 +2704,13 @@ simplify_min_max (gfc_expr *expr, int sign) #define STRING(x) ((x)->expr->value.character.string) if (LENGTH(extremum) < LENGTH(arg)) { - char * tmp = STRING(extremum); + gfc_char_t *tmp = STRING(extremum); - STRING(extremum) = gfc_getmem (LENGTH(arg) + 1); - memcpy (STRING(extremum), tmp, LENGTH(extremum)); - memset (&STRING(extremum)[LENGTH(extremum)], ' ', - LENGTH(arg) - LENGTH(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ LENGTH(extremum) = LENGTH(arg); gfc_free (tmp); @@ -2575,10 +2719,11 @@ simplify_min_max (gfc_expr *expr, int sign) if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0) { gfc_free (STRING(extremum)); - STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1); - memcpy (STRING(extremum), STRING(arg), LENGTH(arg)); - memset (&STRING(extremum)[LENGTH(arg)], ' ', - LENGTH(extremum) - LENGTH(arg)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ } #undef LENGTH @@ -2842,6 +2987,7 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check) { gfc_error ("Result of NEAREST is NaN at %L", &result->where); + gfc_free_expr (result); return &gfc_bad_expr; } @@ -2882,7 +3028,7 @@ gfc_simplify_new_line (gfc_expr *e) gfc_expr *result; result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - result->value.character.string = gfc_getmem (2); + result->value.character.string = gfc_get_wide_string (2); result->value.character.length = 1; result->value.character.string[0] = '\n'; result->value.character.string[1] = '\0'; /* For debugger */ @@ -2952,14 +3098,14 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) { result = gfc_constant_result (BT_INTEGER, kind, &x->where); mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "OR"); } else /* BT_LOGICAL */ { result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result->value.logical = x->value.logical || y->value.logical; + return result; } - - return range_check (result, "OR"); } @@ -3082,8 +3228,12 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) ts.kind = kind; result = gfc_copy_expr (e); if (!gfc_convert_boz (result, &ts)) - return &gfc_bad_expr; + { + gfc_free_expr (result); + return &gfc_bad_expr; + } } + return range_check (result, "REAL"); } @@ -3203,19 +3353,18 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) if (ncop == 0) { - result->value.character.string = gfc_getmem (1); + result->value.character.string = gfc_get_wide_string (1); result->value.character.length = 0; result->value.character.string[0] = '\0'; return result; } result->value.character.length = nlen; - result->value.character.string = gfc_getmem (nlen + 1); + result->value.character.string = gfc_get_wide_string (nlen + 1); for (i = 0; i < ncop; i++) for (j = 0; j < len; j++) - result->value.character.string[j + i * len] - = e->value.character.string[j]; + result->value.character.string[j+i*len]= e->value.character.string[j]; result->value.character.string[nlen] = '\0'; /* For debugger */ return result; @@ -3293,13 +3442,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, goto bad_reshape; } - gfc_free_expr (e); - if (rank >= GFC_MAX_DIMENSIONS) { gfc_error ("Too many dimensions in shape specification for RESHAPE " "at %L", &e->where); - + gfc_free_expr (e); goto bad_reshape; } @@ -3307,9 +3454,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Shape specification at %L cannot be negative", &e->where); + gfc_free_expr (e); goto bad_reshape; } + gfc_free_expr (e); rank++; } @@ -3349,12 +3498,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, goto bad_reshape; } - gfc_free_expr (e); - if (order[i] < 1 || order[i] > rank) { gfc_error ("ORDER parameter of RESHAPE at %L is out of range", &e->where); + gfc_free_expr (e); goto bad_reshape; } @@ -3364,9 +3512,12 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Invalid permutation in ORDER parameter at %L", &e->where); + gfc_free_expr (e); goto bad_reshape; } + gfc_free_expr (e); + x[order[i]] = 1; } } @@ -3406,7 +3557,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, } if (mpz_cmp_ui (index, INT_MAX) > 0) - gfc_internal_error ("Reshaped array too large at %L", &e->where); + gfc_internal_error ("Reshaped array too large at %C"); j = mpz_get_ui (index); @@ -3538,6 +3689,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) { gfc_error ("Result of SCALE overflows its kind at %L", &result->where); + gfc_free_expr (result); return &gfc_bad_expr; } @@ -3570,6 +3722,51 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) } +/* Variants of strspn and strcspn that operate on wide characters. */ + +static size_t +wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c == '\0') + break; + i++; + } + + return i; +} + +static size_t +wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c) + break; + i++; + } + + return i; +} + + gfc_expr * gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) { @@ -3603,8 +3800,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) { if (back == 0) { - indx = strcspn (e->value.character.string, c->value.character.string) - + 1; + indx = wide_strcspn (e->value.character.string, + c->value.character.string) + 1; if (indx > len) indx = 0; } @@ -4309,7 +4506,7 @@ gfc_simplify_trim (gfc_expr *e) lentrim = len - count; result->value.character.length = lentrim; - result->value.character.string = gfc_getmem (lentrim + 1); + result->value.character.string = gfc_get_wide_string (lentrim + 1); for (i = 0; i < lentrim; i++) result->value.character.string[i] = e->value.character.string[i]; @@ -4366,8 +4563,8 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) return result; } - index = strspn (s->value.character.string, set->value.character.string) - + 1; + index = wide_strspn (s->value.character.string, + set->value.character.string) + 1; if (index > len) index = 0; @@ -4411,15 +4608,16 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y) { result = gfc_constant_result (BT_INTEGER, kind, &x->where); mpz_xor (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "XOR"); } else /* BT_LOGICAL */ { result = gfc_constant_result (BT_LOGICAL, kind, &x->where); result->value.logical = (x->value.logical && !y->value.logical) || (!x->value.logical && y->value.logical); + return result; } - return range_check (result, "XOR"); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6e878817363..7f79ee38d6a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -3740,6 +3740,20 @@ build_formal_args (gfc_symbol *new_proc_sym, gfc_current_ns = parent_ns; } +static int +std_for_isocbinding_symbol (int id) +{ + switch (id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a:\ + return d; +#include "iso-c-binding.def" +#undef NAMED_INTCST + default: + return GFC_STD_F2003; + } +} /* Generate the given set of C interoperable kind objects, or all interoperable kinds. This function will only be given kind objects @@ -3765,6 +3779,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1]; int index; + if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE) + return; tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); /* Already exists in this scope so don't re-add it. @@ -3788,7 +3804,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, switch (s) { -#define NAMED_INTCST(a,b,c) case a : +#define NAMED_INTCST(a,b,c,d) case a : #define NAMED_REALCST(a,b,c) case a : #define NAMED_CMPXCST(a,b,c) case a : #define NAMED_LOGCST(a,b,c) case a : @@ -3833,9 +3849,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, tmp_sym->value->ts.is_c_interop = 1; tmp_sym->value->ts.is_iso_c = 1; tmp_sym->value->value.character.length = 1; - tmp_sym->value->value.character.string = gfc_getmem (2); + tmp_sym->value->value.character.string = gfc_get_wide_string (2); tmp_sym->value->value.character.string[0] - = (char) c_interop_kinds_table[s].value; + = (gfc_char_t) c_interop_kinds_table[s].value; tmp_sym->value->value.character.string[1] = '\0'; tmp_sym->ts.cl = gfc_get_charlen (); tmp_sym->ts.cl->length = gfc_int_expr (1); diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index e16c163ceaa..389e2a53917 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -73,9 +73,9 @@ size_logical (int kind) static size_t -size_character (int length) +size_character (int length, int kind) { - return length; + return length * kind; } @@ -100,7 +100,16 @@ gfc_target_expr_size (gfc_expr *e) case BT_LOGICAL: return size_logical (e->ts.kind); case BT_CHARACTER: - return size_character (e->value.character.length); + if (e->expr_type == EXPR_SUBSTRING && e->ref) + { + int start, end; + + gfc_extract_int (e->ref->u.ss.start, &start); + gfc_extract_int (e->ref->u.ss.end, &end); + return size_character (MAX(end - start + 1, 0), e->ts.kind); + } + else + return size_character (e->value.character.length, e->ts.kind); case BT_HOLLERITH: return e->representation.length; case BT_DERIVED: @@ -174,11 +183,20 @@ encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size static int -encode_character (int length, char *string, unsigned char *buffer, - size_t buffer_size) +encode_character (int kind, int length, gfc_char_t *string, + unsigned char *buffer, size_t buffer_size) { - gcc_assert (buffer_size >= size_character (length)); - memcpy (buffer, string, length); + char *s; + + gcc_assert (buffer_size >= size_character (length, kind)); + /* FIXME -- when we support wide character types, we'll need to go + via integers for them. For now, we keep the simple memcpy(). */ + gcc_assert (kind == gfc_default_character_kind); + + s = gfc_widechar_to_char (string, length); + memcpy (buffer, s, length); + gfc_free (s); + return length; } @@ -222,7 +240,8 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, return encode_array (source, buffer, buffer_size); gcc_assert (source->expr_type == EXPR_CONSTANT - || source->expr_type == EXPR_STRUCTURE); + || source->expr_type == EXPR_STRUCTURE + || source->expr_type == EXPR_SUBSTRING); /* If we already have a target-memory representation, we use that rather than recreating one. */ @@ -248,9 +267,24 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, return encode_logical (source->ts.kind, source->value.logical, buffer, buffer_size); case BT_CHARACTER: - return encode_character (source->value.character.length, - source->value.character.string, buffer, - buffer_size); + if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) + return encode_character (source->ts.kind, + source->value.character.length, + source->value.character.string, buffer, + buffer_size); + else + { + int start, end; + + gcc_assert (source->expr_type == EXPR_SUBSTRING); + gfc_extract_int (source->ref->u.ss.start, &start); + gfc_extract_int (source->ref->u.ss.end, &end); + return encode_character (source->ts.kind, + MAX(end - start + 1, 0), + &source->value.character.string[start-1], + buffer, buffer_size); + } + case BT_DERIVED: return encode_derived (source, buffer, buffer_size); default: @@ -333,7 +367,8 @@ gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, { int size; size = gfc_interpret_float (kind, &buffer[0], buffer_size, real); - size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary); + size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, + imaginary); return size; } @@ -351,18 +386,24 @@ gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, int -gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +gfc_interpret_character (unsigned char *buffer, size_t buffer_size, + gfc_expr *result) { + int i; + if (result->ts.cl && result->ts.cl->length) result->value.character.length = - (int)mpz_get_ui (result->ts.cl->length->value.integer); + (int) mpz_get_ui (result->ts.cl->length->value.integer); - gcc_assert (buffer_size >= size_character (result->value.character.length)); + gcc_assert (buffer_size >= size_character (result->value.character.length, + result->ts.kind)); result->value.character.string = - gfc_getmem (result->value.character.length + 1); - memcpy (result->value.character.string, buffer, - result->value.character.length); - result->value.character.string [result->value.character.length] = '\0'; + gfc_get_wide_string (result->value.character.length + 1); + + gcc_assert (result->ts.kind == gfc_default_character_kind); + for (i = 0; i < result->value.character.length; i++) + result->value.character.string[i] = (gfc_char_t) buffer[i]; + result->value.character.string[result->value.character.length] = '\0'; return result->value.character.length; } @@ -481,7 +522,9 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, } if (result->ts.type == BT_CHARACTER) - result->representation.string = result->value.character.string; + result->representation.string + = gfc_widechar_to_char (result->value.character.string, + result->value.character.length); else { result->representation.string = diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5fc56883bc9..784f1bc40d0 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -959,9 +959,10 @@ gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, } -/* Assign an element of an array constructor. */ +/* Variables needed for bounds-checking. */ static bool first_len; static tree first_len_val; +static bool typespec_chararray_ctor; static void gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, @@ -998,7 +999,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, se->string_length, se->expr); } - if (flag_bounds_check) + if (flag_bounds_check && !typespec_chararray_ctor) { if (first_len) { @@ -1677,7 +1678,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) tree loopfrom; bool dynamic; - if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER) + /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no + typespec was given for the array constructor. */ + typespec_chararray_ctor = (ss->expr->ts.cl + && ss->expr->ts.cl->length_from_typespec); + + if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER + && !typespec_chararray_ctor) { first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); first_len = true; @@ -1688,7 +1695,27 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) c = ss->expr->value.constructor; if (ss->expr->ts.type == BT_CHARACTER) { - bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length); + bool const_string; + + /* get_array_ctor_strlen walks the elements of the constructor, if a + typespec was given, we already know the string length and want the one + specified there. */ + if (typespec_chararray_ctor && ss->expr->ts.cl->length + && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT) + { + gfc_se length_se; + + const_string = false; + gfc_init_se (&length_se, NULL); + gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length, + gfc_charlen_type_node); + ss->string_length = length_se.expr; + gfc_add_block_to_block (&loop->pre, &length_se.pre); + gfc_add_block_to_block (&loop->post, &length_se.post); + } + else + const_string = get_array_ctor_strlen (&loop->pre, c, + &ss->string_length); /* Complex character array constructors should have been taken care of and not end up here. */ @@ -1873,20 +1900,21 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript) /* Scalar expression. Evaluate this now. This includes elemental dimension indices, but not array section bounds. */ gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ss->expr); - gfc_add_block_to_block (&loop->pre, &se.pre); + gfc_conv_expr (&se, ss->expr); + gfc_add_block_to_block (&loop->pre, &se.pre); - if (ss->expr->ts.type != BT_CHARACTER) - { - /* Move the evaluation of scalar expressions outside the - scalarization loop. */ - if (subscript) - se.expr = convert(gfc_array_index_type, se.expr); - se.expr = gfc_evaluate_now (se.expr, &loop->pre); - gfc_add_block_to_block (&loop->pre, &se.post); - } - else - gfc_add_block_to_block (&loop->post, &se.post); + if (ss->expr->ts.type != BT_CHARACTER) + { + /* Move the evaluation of scalar expressions outside the + scalarization loop, except for WHERE assignments. */ + if (subscript) + se.expr = convert(gfc_array_index_type, se.expr); + if (!ss->where) + se.expr = gfc_evaluate_now (se.expr, &loop->pre); + gfc_add_block_to_block (&loop->pre, &se.post); + } + else + gfc_add_block_to_block (&loop->post, &se.post); ss->data.scalar.expr = se.expr; ss->string_length = se.string_length; @@ -3083,6 +3111,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) info->start[n]); tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, info->stride[n]); + tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, + build_int_cst (gfc_array_index_type, 0)); /* We remember the size of the first section, and check all the others against this. */ if (size[n]) @@ -3435,8 +3465,10 @@ gfc_conv_loop_setup (gfc_loopinfo * loop) for (i = 0; i<=last; i++){...}; */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); - tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type, + tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, info->stride[n]); + tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, + build_int_cst (gfc_array_index_type, -1)); loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); /* Make the loop variable start at 0. */ loop->from[n] = gfc_index_zero_node; diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 37251eff6db..6c9032f972a 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -105,7 +105,8 @@ gfc_build_localized_cstring_const (const char *msgid) tree gfc_conv_string_init (tree length, gfc_expr * expr) { - char *s; + gfc_char_t *s; + char *c; HOST_WIDE_INT len; int slen; tree str; @@ -120,14 +121,21 @@ gfc_conv_string_init (tree length, gfc_expr * expr) if (len > slen) { - s = gfc_getmem (len); - memcpy (s, expr->value.character.string, slen); - memset (&s[slen], ' ', len - slen); - str = gfc_build_string_const (len, s); + s = gfc_get_wide_string (len); + memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); + gfc_wide_memset (&s[slen], ' ', len - slen); + + /* FIXME -- currently ignore wide character strings; see assert + above. */ + c = gfc_widechar_to_char (s, len); gfc_free (s); } else - str = gfc_build_string_const (len, expr->value.character.string); + c = gfc_widechar_to_char (expr->value.character.string, + expr->value.character.length); + + str = gfc_build_string_const (len, c); + gfc_free (c); return str; } @@ -214,6 +222,9 @@ gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source) tree gfc_conv_constant_to_tree (gfc_expr * expr) { + tree res; + char *s; + gcc_assert (expr->expr_type == EXPR_CONSTANT); /* If it is has a prescribed memory representation, we build a string @@ -267,8 +278,12 @@ gfc_conv_constant_to_tree (gfc_expr * expr) } case BT_CHARACTER: - return gfc_build_string_const (expr->value.character.length, - expr->value.character.string); + gcc_assert (expr->ts.kind == 1); + s = gfc_widechar_to_char (expr->value.character.string, + expr->value.character.length); + res = gfc_build_string_const (expr->value.character.length, s); + gfc_free (s); + return res; case BT_HOLLERITH: return gfc_build_string_const (expr->representation.length, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d204579c75f..49eb2aa8b41 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -116,6 +116,16 @@ tree gfor_fndecl_string_trim; tree gfor_fndecl_string_minmax; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; +tree gfor_fndecl_compare_string_char4; +tree gfor_fndecl_concat_string_char4; +tree gfor_fndecl_string_len_trim_char4; +tree gfor_fndecl_string_index_char4; +tree gfor_fndecl_string_scan_char4; +tree gfor_fndecl_string_verify_char4; +tree gfor_fndecl_string_trim_char4; +tree gfor_fndecl_string_minmax_char4; +tree gfor_fndecl_adjustl_char4; +tree gfor_fndecl_adjustr_char4; /* Other misc. runtime library functions. */ @@ -733,7 +743,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) /* Create a descriptorless array pointer. */ as = sym->as; packed = PACKED_NO; - if (!gfc_option.flag_repack_arrays) + + /* Even when -frepack-arrays is used, symbols with TARGET attribute + are not repacked. */ + if (!gfc_option.flag_repack_arrays || sym->attr.target) { if (as->type == AS_ASSUMED_SIZE) packed = PACKED_FULL; @@ -1197,7 +1210,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) if (sym->attr.pure || sym->attr.elemental) { if (sym->attr.function && !gfc_return_by_reference (sym)) - DECL_IS_PURE (fndecl) = 1; + DECL_PURE_P (fndecl) = 1; /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT) parameters and don't use alternate returns (is this allowed?). In that case, calls to them are meaningless, and @@ -1324,7 +1337,7 @@ build_function_decl (gfc_symbol * sym) including an alternate return. In that case it can also be marked as PURE. See also in gfc_get_extern_function_decl(). */ if (attr.function && !gfc_return_by_reference (sym)) - DECL_IS_PURE (fndecl) = 1; + DECL_PURE_P (fndecl) = 1; TREE_SIDE_EFFECTS (fndecl) = 0; } @@ -2004,64 +2017,145 @@ gfc_build_intrinsic_function_decls (void) tree gfc_int8_type_node = gfc_get_int_type (8); tree gfc_int16_type_node = gfc_get_int_type (16); tree gfc_logical4_type_node = gfc_get_logical_type (4); + tree pchar1_type_node = gfc_get_pchar_type (1); + tree pchar4_type_node = gfc_get_pchar_type (4); /* String functions. */ gfor_fndecl_compare_string = gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")), integer_type_node, 4, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node); + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_concat_string = gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")), - void_type_node, - 6, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node); + void_type_node, 6, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_len_trim = gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), - gfc_int4_type_node, - 2, gfc_charlen_type_node, - pchar_type_node); + gfc_int4_type_node, 2, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_index = gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_scan = gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_verify = gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_trim = gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")), - void_type_node, - 4, - build_pointer_type (gfc_charlen_type_node), - ppvoid_type_node, - gfc_charlen_type_node, - pchar_type_node); + void_type_node, 4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_minmax = gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - ppvoid_type_node, integer_type_node, - integer_type_node); + void_type_node, -4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), + integer_type_node, integer_type_node); + + gfor_fndecl_adjustl = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), + void_type_node, 3, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_adjustr = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), + void_type_node, 3, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_compare_string_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("compare_string_char4")), + integer_type_node, 4, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_concat_string_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("concat_string_char4")), + void_type_node, 6, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_len_trim_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_len_trim_char4")), + gfc_charlen_type_node, 2, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_index_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_index_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_scan_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_scan_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_verify_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_verify_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_trim_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_trim_char4")), + void_type_node, 4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_minmax_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_minmax_char4")), + void_type_node, -4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), + integer_type_node, integer_type_node); + + gfor_fndecl_adjustl_char4 = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")), + void_type_node, 3, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_adjustr_char4 = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")), + void_type_node, 3, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + /* Misc. functions. */ gfor_fndecl_ttynam = gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")), @@ -2086,20 +2180,6 @@ gfc_build_intrinsic_function_decls (void) gfc_charlen_type_node, gfc_int8_type_node); - gfor_fndecl_adjustl = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, pchar_type_node); - - gfor_fndecl_adjustr = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, pchar_type_node); - gfor_fndecl_sc_kind = gfc_build_library_function_decl (get_identifier (PREFIX("selected_char_kind")), diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index aae1d72fe1f..563e840c64a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1003,15 +1003,11 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) static void gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) { - gfc_se lse; - gfc_se rse; - tree len; - tree type; - tree var; - tree tmp; + gfc_se lse, rse; + tree len, type, var, tmp, fndecl; gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER - && expr->value.op.op2->ts.type == BT_CHARACTER); + && expr->value.op.op2->ts.type == BT_CHARACTER); gfc_init_se (&lse, se); gfc_conv_expr (&lse, expr->value.op.op1); @@ -1036,9 +1032,14 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) var = gfc_conv_string_tmp (se, type, len); /* Do the actual concatenation. */ - tmp = build_call_expr (gfor_fndecl_concat_string, 6, - len, var, - lse.string_length, lse.expr, + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_concat_string; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_concat_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr, rse.string_length, rse.expr); gfc_add_expr_to_block (&se->pre, tmp); @@ -1212,7 +1213,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_conv_string_parameter (&rse); lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, - rse.string_length, rse.expr); + rse.string_length, rse.expr, + expr->value.op.op1->ts.kind); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1313,7 +1315,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) { tree sc1; tree sc2; @@ -1325,17 +1327,28 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) sc1 = gfc_to_single_character (len1, str1); sc2 = gfc_to_single_character (len2, str2); - /* Deal with single character specially. */ if (sc1 != NULL_TREE && sc2 != NULL_TREE) { + /* Deal with single character specially. */ sc1 = fold_convert (integer_type_node, sc1); sc2 = fold_convert (integer_type_node, sc2); tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); } - else - /* Build a call for the comparison. */ - tmp = build_call_expr (gfor_fndecl_compare_string, 4, - len1, str1, len2, str2); + else + { + /* Build a call for the comparison. */ + tree fndecl; + + if (kind == 1) + fndecl = gfor_fndecl_compare_string; + else if (kind == 4) + fndecl = gfor_fndecl_compare_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2); + } + return tmp; } @@ -2981,7 +2994,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tree arglen; gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); tmp = gfc_build_addr_expr (build_pointer_type (type), @@ -3488,13 +3501,18 @@ static void gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; + char *s; ref = expr->ref; gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); - se->expr = gfc_build_string_const (expr->value.character.length, - expr->value.character.string); + gcc_assert (expr->ts.kind == gfc_default_character_kind); + s = gfc_widechar_to_char (expr->value.character.string, + expr->value.character.length); + se->expr = gfc_build_string_const (expr->value.character.length, s); + gfc_free (s); + se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 9f022e7a09d..03ddefd5e66 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -938,6 +938,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); + se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr, + gfc_index_zero_node); } else se->expr = gfc_index_one_node; @@ -1507,7 +1509,7 @@ static void gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) { tree *args; - tree var, len, fndecl, tmp, cond; + tree var, len, fndecl, tmp, cond, function; unsigned int nargs; nargs = gfc_intrinsic_argument_list_length (expr); @@ -1522,10 +1524,17 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) args[2] = build_int_cst (NULL_TREE, op); args[3] = build_int_cst (NULL_TREE, nargs / 2); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_minmax; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_minmax_char4; + else + gcc_unreachable (); + /* Make the function call. */ - fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)), - fndecl, nargs + 4, args); + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + nargs + 4, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ @@ -2689,12 +2698,20 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + int kind = expr->value.function.actual->expr->ts.kind; + tree args[2], type, fndecl; gfc_conv_intrinsic_function_args (se, expr, args, 2); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]); + + if (kind == 1) + fndecl = gfor_fndecl_string_len_trim; + else if (kind == 4) + fndecl = gfor_fndecl_string_len_trim_char4; + else + gcc_unreachable (); + + se->expr = build_call_expr (fndecl, 2, args[0], args[1]); se->expr = convert (type, se->expr); } @@ -2734,12 +2751,12 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, static void gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + tree args[2], type, pchartype; gfc_conv_intrinsic_function_args (se, expr, args, 2); gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); - args[1] = fold_build1 (NOP_EXPR, pchar_type_node, args[1]); + pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); + args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]); type = gfc_typenode_for_spec (&expr->ts); se->expr = build_fold_indirect_ref (args[1]); @@ -3271,7 +3288,9 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) gfc_conv_intrinsic_function_args (se, expr, args, 4); - se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]); + se->expr + = gfc_build_compare_string (args[0], args[1], args[2], args[3], + expr->value.function.actual->expr->ts.kind); se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); } @@ -3826,6 +3845,7 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) tree type; tree cond; tree fndecl; + tree function; tree *args; unsigned int num_args; @@ -3841,9 +3861,16 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) args[0] = build_fold_addr_expr (len); args[1] = addr; - fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)), - fndecl, num_args, args); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_trim; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_trim_char4; + else + gcc_unreachable (); + + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + num_args, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ @@ -4031,7 +4058,8 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { gfc_intrinsic_sym *isym; const char *name; - int lib; + int lib, kind; + tree fndecl; isym = expr->value.function.isym; @@ -4079,11 +4107,27 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_SCAN: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_scan; + else if (kind == 4) + fndecl = gfor_fndecl_string_scan_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_VERIFY: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_verify; + else if (kind == 4) + fndecl = gfor_fndecl_string_verify_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_ALLOCATED: @@ -4099,11 +4143,25 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_ADJUSTL: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustl; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustl_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_ADJUSTR: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustr; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustr_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_AIMAG: @@ -4250,7 +4308,15 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_INDEX: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_index; + else if (kind == 4) + fndecl = gfor_fndecl_string_index_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_IOR: diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 6316a426918..2f35002a5ac 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1391,8 +1391,7 @@ gfc_new_nml_name_expr (const char * name) nml_name->ts.kind = gfc_default_character_kind; nml_name->ts.type = BT_CHARACTER; nml_name->value.character.length = strlen(name); - nml_name->value.character.string = gfc_getmem (strlen (name) + 1); - strcpy (nml_name->value.character.string, name); + nml_name->value.character.string = gfc_char_to_widechar (name); return nml_name; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 5660ae61811..64829e370c1 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -119,11 +119,14 @@ gfc_trans_label_assign (gfc_code * code) } else { - label_str = code->label->format->value.character.string; label_len = code->label->format->value.character.length; + label_str + = gfc_widechar_to_char (code->label->format->value.character.string, + label_len); len_tree = build_int_cst (NULL_TREE, label_len); label_tree = gfc_build_string_const (label_len + 1, label_str); label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); + gfc_free (label_str); } gfc_add_modify_expr (&se.pre, len, len_tree); @@ -3147,6 +3150,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, { /* The rhs is scalar. Add a ss for the expression. */ rss = gfc_get_ss (); + rss->where = 1; rss->next = gfc_ss_terminator; rss->type = GFC_SS_SCALAR; rss->expr = expr2; @@ -3309,6 +3313,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, gfc_code *cblock; gfc_code *cnext; tree tmp; + tree cond; tree count1, count2; bool need_cmask; bool need_pmask; @@ -3374,6 +3379,13 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, size = compute_overall_iter_number (nested_forall_info, inner_size, &inner_size_body, block); + /* Check whether the size is negative. */ + cond = fold_build2 (LE_EXPR, boolean_type_node, size, + gfc_index_zero_node); + size = fold_build3 (COND_EXPR, gfc_array_index_type, cond, + gfc_index_zero_node, size); + size = gfc_evaluate_now (size, block); + /* Allocate temporary for WHERE mask if needed. */ if (need_cmask) cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, @@ -3575,6 +3587,7 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) if (tsss == gfc_ss_terminator) { tsss = gfc_get_ss (); + tsss->where = 1; tsss->next = gfc_ss_terminator; tsss->type = GFC_SS_SCALAR; tsss->expr = tsrc; @@ -3592,6 +3605,7 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) if (esss == gfc_ss_terminator) { esss = gfc_get_ss (); + esss->where = 1; esss->next = gfc_ss_terminator; esss->type = GFC_SS_SCALAR; esss->expr = esrc; @@ -3706,19 +3720,28 @@ gfc_trans_where (gfc_code * code) block is dependence free if cond is not dependent on writes to x1 and x2, y1 is not dependent on writes to x2, and y2 is not dependent on writes to x1, and both y's are not - dependent upon their own x's. */ + dependent upon their own x's. In addition to this, the + final two dependency checks below exclude all but the same + array reference if the where and elswhere destinations + are the same. In short, this is VERY conservative and this + is needed because the two loops, required by the standard + are coalesced in gfc_trans_where_3. */ if (!gfc_check_dependency(cblock->next->expr, cblock->expr, 0) && !gfc_check_dependency(eblock->next->expr, cblock->expr, 0) && !gfc_check_dependency(cblock->next->expr, - eblock->next->expr2, 0) + eblock->next->expr2, 1) + && !gfc_check_dependency(eblock->next->expr, + cblock->next->expr2, 1) + && !gfc_check_dependency(cblock->next->expr, + cblock->next->expr2, 1) && !gfc_check_dependency(eblock->next->expr, - cblock->next->expr2, 0) + eblock->next->expr2, 1) && !gfc_check_dependency(cblock->next->expr, - cblock->next->expr2, 0) + eblock->next->expr, 0) && !gfc_check_dependency(eblock->next->expr, - eblock->next->expr2, 0)) + cblock->next->expr, 0)) return gfc_trans_where_3 (cblock, eblock); } } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 6e98db7dbfa..1c15d644ab4 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -83,6 +83,11 @@ gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; +#define MAX_CHARACTER_KINDS 2 +gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; + /* The integer kind to use for array indices. This will be set to the proper value based on target information from the backend. */ @@ -219,7 +224,7 @@ void init_c_interop_kinds (void) c_interop_kinds_table[i].f90_type = BT_UNKNOWN; } -#define NAMED_INTCST(a,b,c) \ +#define NAMED_INTCST(a,b,c,d) \ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ c_interop_kinds_table[a].f90_type = BT_INTEGER; \ c_interop_kinds_table[a].value = c; @@ -262,7 +267,7 @@ void gfc_init_kinds (void) { enum machine_mode mode; - int i_index, r_index; + int i_index, r_index, kind; bool saw_i4 = false, saw_i8 = false; bool saw_r4 = false, saw_r8 = false, saw_r16 = false; @@ -450,8 +455,27 @@ gfc_init_kinds (void) gfc_default_logical_kind = gfc_default_integer_kind; gfc_default_complex_kind = gfc_default_real_kind; + /* We only have two character kinds: ASCII and UCS-4. + ASCII corresponds to a 8-bit integer type, if one is available. + UCS-4 corresponds to a 32-bit integer type, if one is available. */ + i_index = 0; + if ((kind = get_int_kind_from_width (8)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 8; + gfc_character_kinds[i_index].name = "ascii"; + i_index++; + } + if ((kind = get_int_kind_from_width (32)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 32; + gfc_character_kinds[i_index].name = "iso_10646"; + i_index++; + } + /* Choose the smallest integer kind for our default character. */ - gfc_default_character_kind = gfc_integer_kinds[0].kind; + gfc_default_character_kind = gfc_character_kinds[0].kind; gfc_character_storage_size = gfc_default_character_kind * 8; /* Choose the integer kind the same size as "void*" for our index kind. */ @@ -505,7 +529,13 @@ validate_logical (int kind) static int validate_character (int kind) { - return kind == gfc_default_character_kind ? 0 : -1; + int i; + + for (i = 0; gfc_character_kinds[i].kind; i++) + if (gfc_character_kinds[i].kind == kind) + return i; + + return -1; } /* Validate a kind given a basic type. The return value is the same @@ -580,6 +610,24 @@ gfc_build_int_type (gfc_integer_info *info) } static tree +gfc_build_uint_type (int size) +{ + if (size == CHAR_TYPE_SIZE) + return unsigned_char_type_node; + if (size == SHORT_TYPE_SIZE) + return short_unsigned_type_node; + if (size == INT_TYPE_SIZE) + return unsigned_type_node; + if (size == LONG_TYPE_SIZE) + return long_unsigned_type_node; + if (size == LONG_LONG_TYPE_SIZE) + return long_long_unsigned_type_node; + + return make_unsigned_type (size); +} + + +static tree gfc_build_real_type (gfc_real_info *info) { int mode_precision = info->mode_precision; @@ -717,9 +765,17 @@ gfc_init_types (void) PUSH_TYPE (name_buf, type); } - gfc_character1_type_node = build_qualified_type (unsigned_char_type_node, - TYPE_UNQUALIFIED); - PUSH_TYPE ("character(kind=1)", gfc_character1_type_node); + for (index = 0; gfc_character_kinds[index].kind != 0; ++index) + { + type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); + type = build_qualified_type (type, TYPE_UNQUALIFIED); + snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", + gfc_character_kinds[index].kind); + PUSH_TYPE (name_buf, type); + gfc_character_types[index] = type; + gfc_pcharacter_types[index] = build_pointer_type (type); + } + gfc_character1_type_node = gfc_character_types[0]; PUSH_TYPE ("byte", unsigned_char_type_node); PUSH_TYPE ("void", void_type_node); @@ -799,6 +855,21 @@ gfc_get_logical_type (int kind) int index = gfc_validate_kind (BT_LOGICAL, kind, true); return index < 0 ? 0 : gfc_logical_types[index]; } + +tree +gfc_get_char_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_character_types[index]; +} + +tree +gfc_get_pchar_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_pcharacter_types[index]; +} + /* Create a character type with the given kind and length. */ @@ -810,7 +881,7 @@ gfc_get_character_type_len (int kind, tree len) gfc_validate_kind (BT_CHARACTER, kind, false); bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); - type = build_array_type (gfc_character1_type_node, bounds); + type = build_array_type (gfc_get_char_type (kind), bounds); TYPE_STRING_FLAG (type) = 1; return type; diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 7b1da3e1113..0da736d6d5c 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -55,6 +55,8 @@ tree gfc_get_int_type (int); tree gfc_get_real_type (int); tree gfc_get_complex_type (int); tree gfc_get_logical_type (int); +tree gfc_get_char_type (int); +tree gfc_get_pchar_type (int); tree gfc_get_character_type (int, gfc_charlen *); tree gfc_get_character_type_len (int, tree); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index a9951e48c57..f303128a28d 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -440,12 +440,12 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, /* Call malloc to allocate size bytes of memory, with special conditions: + if size < 0, generate a runtime error, - + if size == 0, return a NULL pointer, + + if size == 0, return a malloced area of size 1, + if malloc returns NULL, issue a runtime error. */ tree gfc_call_malloc (stmtblock_t * block, tree type, tree size) { - tree tmp, msg, negative, zero, malloc_result, null_result, res; + tree tmp, msg, negative, malloc_result, null_result, res; stmtblock_t block2; size = gfc_evaluate_now (size, block); @@ -468,6 +468,10 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) /* Call malloc and check the result. */ gfc_start_block (&block2); + + size = fold_build2 (MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1)); + gfc_add_modify_expr (&block2, res, build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1, size)); @@ -481,13 +485,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) gfc_add_expr_to_block (&block2, tmp); malloc_result = gfc_finish_block (&block2); - /* size == 0 */ - zero = fold_build2 (EQ_EXPR, boolean_type_node, size, - build_int_cst (size_type_node, 0)); - tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res, - build_int_cst (pvoid_type_node, 0)); - tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result); - gfc_add_expr_to_block (block, tmp); + gfc_add_expr_to_block (block, malloc_result); if (type != NULL) res = fold_convert (type, res); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3e812a89028..ffd1b84c875 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -201,8 +201,9 @@ typedef struct gfc_ss /* This is used by assignments requiring temporaries. The bits specify which loops the terms appear in. This will be 1 for the RHS expressions, - 2 for the LHS expressions, and 3(=1|2) for the temporary. */ - unsigned useflags:2; + 2 for the LHS expressions, and 3(=1|2) for the temporary. The bit + 'where' suppresses precalculation of scalars in WHERE assignments. */ + unsigned useflags:2, where:1; } gfc_ss; #define gfc_get_ss() gfc_getmem(sizeof(gfc_ss)) @@ -277,7 +278,7 @@ void gfc_make_safe_expr (gfc_se * se); void gfc_conv_string_parameter (gfc_se * se); /* Compare two strings. */ -tree gfc_build_compare_string (tree, tree, tree, tree); +tree gfc_build_compare_string (tree, tree, tree, tree, int); /* Add an item to the end of TREE_LIST. */ tree gfc_chainon_list (tree, tree); @@ -550,6 +551,16 @@ extern GTY(()) tree gfor_fndecl_string_trim; extern GTY(()) tree gfor_fndecl_string_minmax; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; +extern GTY(()) tree gfor_fndecl_compare_string_char4; +extern GTY(()) tree gfor_fndecl_concat_string_char4; +extern GTY(()) tree gfor_fndecl_string_len_trim_char4; +extern GTY(()) tree gfor_fndecl_string_index_char4; +extern GTY(()) tree gfor_fndecl_string_scan_char4; +extern GTY(()) tree gfor_fndecl_string_verify_char4; +extern GTY(()) tree gfor_fndecl_string_trim_char4; +extern GTY(()) tree gfor_fndecl_string_minmax_char4; +extern GTY(()) tree gfor_fndecl_adjustl_char4; +extern GTY(()) tree gfor_fndecl_adjustr_char4; /* Other misc. runtime library functions. */ extern GTY(()) tree gfor_fndecl_size0; |