diff options
Diffstat (limited to 'gcc/fortran')
42 files changed, 3713 insertions, 457 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e8d487a6341..9e06dfe398e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,365 @@ +2005-04-06 Steven G. Kargl <kargls@comcast.net> + + * invoke.texi: Remove documentation of -std=f90. + +2005-04-06 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * expr.c (gfc_check_assign): Don't allow NULL as rhs in a + non-pointer assignment. + +2005-04-05 Feng Wang <fengwang@nudt.edu.cn> + + PR fortran/15959 + PR fortran/20713 + + * array.c (resolve_character_array_constructor): New function. Set + constant character array's character length. + (gfc_resolve_array_constructor): Use it. + * decl.c (add_init_expr_to_sym): Set symbol and initializer character + length. + (gfc_set_constant_character_len): New function. Set constant character + expression according the given length. + * match.h (gfc_set_constant_character_len): Add prototype. + +2005-04-04 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * intrinsic.texi: BES?? functions are not in the f95 standard. + +2005-04-03 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * intrinsic.texi: Document COS, EXP, LOG, LOG10, SIN, SQRT, TAN. + +2005-04-03 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * intrinsic.texi: Document BESJ0, BESJ1, BESJN, BESY0, BESY1, + BESYN, ATAN, COSH, ERF, ERC, SINH, TANH. + +2005-04-02 Steven G. Kargl <kargls@comcast.net> + + * intrinsic.texi: Document ALLOCATED, ANINT, ANY, ASIN; Fix typos. + +2005-03-30 Canqun Yang <canqun@nudt.edu.cn> + + * trans-common.c (create_common): Build RECORD_NODE for common blocks + contain no equivalence objects. + (add_equivalences): New argument saw_equiv. + (trans_common): New local variable saw_equiv. + (finish_equivalences): Add a local variable dummy, Always pass true + for the 3rd parameter to create_common. + +2005-03-29 Steven G. Kargl <kargls@comcast.net> + + * gfortran.h (option_t): Change d8, i8, r8 to flag_default_double, + flag_default_integer, flag_default_real + * invoke.texi: Update documentation + * lang.opt: Remove d8, i8, r8 definitions; Add fdefault-double-8 + fdefault-integer-8, and fdefault-real-8 definitions. + * options.c (gfc_init_options): Set option defaults + (gfc_handle_option): Handle command line options. + * trans-types.c (gfc_init_kinds): Use options. + +2005-03-27 Steven G. Kargl <kargls@comcast.net> + + * intrinsic.texi: Document AIMAG, AINT, ALL + +2005-03-25 Steven G. Kargl <kargls@comcast.net> + + * intrinsic.texi: Fix "make dvi" + +2005-03-24 Steven G. Kargl <kargls@comcast.net> + + * intrinsic.texi: New file. + * gfortran.texi: Include it; white space change; fix typo. + +2005-03-22 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * check.c (gfc_check_chdir, gfc_check_chdir_sub, gfc_check_kill, + gfc_check_kill_sub, gfc_check_link, gfc_check_link_sub, + gfc_check_symlnk, gfc_check_symlnk_sub, gfc_check_rename, + gfc_check_rename_sub, gfc_check_sleep_sub, gfc_check_gerror, + gfc_check_getlog, gfc_check_hostnm, gfc_check_hostnm_sub, + gfc_check_perror): new functions to check newly implemented + g77 intrinsics. + * gfortran.h: adding symbols for new intrinsics. + * intrinsic.c (add_functions): adding new intrinsics. + (add_subroutines): adding new intrinsics. + * intrinsic.h: prototype for all checking and resolving + functions. + * iresolve.c (gfc_resolve_chdir, gfc_resolve_chdir_sub, + gfc_resolve_hostnm, gfc_resolve_ierrno, gfc_resolve_kill, + gfc_resolve_link, gfc_resolve_rename, gfc_resolve_symlnk, + gfc_resolve_time, gfc_resolve_time8, gfc_resolve_rename_sub, + gfc_resolve_kill_sub, gfc_resolve_link_sub, + gfc_resolve_symlnk_sub, gfc_resolve_sleep_sub, + gfc_resolve_gerror, gfc_resolve_getlog, gfc_resolve_hostnm_sub, + gfc_resolve_perror): new functions to resolve intrinsics. + * trans-intrinsic.c (gfc_conv_intrinsic_function): add case + for new symbols. + +2005-03-19 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * dump-parse-tree.c (gfc_show_expr): Dump name of namespace + in which the variable is declared. + + PR fortran/18525 + * resolve.c (was_declared): Also check for dummy attribute. + +2005-03-19 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (arith): Remove ARITH_0TO0. + * arith.c (gfc_arith_error): Remove handling of ARITH_0TO0. + (gfc_arith_power): Remove special casing of zero to integral + power zero. + +2005-03-17 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * invoke.texi: Fix typos. + +2005-03-15 Feng Wang <fengwang@nudt.edu.cn> + + PR fortran/18827 + * io.c (resolve_tag): Add checking on assigned label. + (match_dt_format): Does not set symbol assign attribute. + * match.c (gfc_match_goto):Does not set symbol assign attribute. + * resolve.c (resolve_code): Add checking on assigned label. + * trans-common.c (build_field): Deals with common variable assigned + a label. + * trans-stmt.c (gfc_conv_label_variable): New function. + (gfc_trans_label_assign): Use it. + (gfc_trans_goto): Ditto. + * trans-io.c (set_string): Ditto. + * trans.h (gfc_conv_label_variable): Add prototype. + +2005-03-14 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/20467 + * symbol.c (check_conflict): A dummy argument can't be a statement + function. + +2005-03-13 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/16907 + * resolve.c (gfc_resolve_index): Allow REAL indices as an extension. + +2005-03-13 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/20323 + * resolve.c (gfc_resolve): Check if character lengths are + specification expressions. + +2005-03-12 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/20361 + * trans-array.c (gfc_stack_space_left): Remove unused variable. + (gfc_can_put_var_on_stack): Move to trans-decl.c, remove #if 0'ed + code. + * trans-array.h (gfc_stack_space_left, gfc_can_put_var_on_stack): + Remove declaration / prototype. + * trans-common.c (build_equiv_decl): Give union a name. Check if + it can be put on the stack. + * trans-decl.c (gfc_stack_space_left): Move function here. + (gfc_build_qualified_array): Fix comment typo. + * trans.h (gfc_put_var_on_stack): Add prototype. + +2005-03-05 Steven G. Kargl <kargls@comcast.net> + + PR fortran/19936 + * primary.c (match_complex_constant): Mangled complex constant may + be an implied do-loop. Give implied do-loop matcher a chance. + +2005-03-05 Steven G. Kargl <kargls@comcast.net> + + PR fortran/19754 + * resolve.c (compare_shapes): New function. + (resolve_operator): Use it. + +2005-03-04 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/19673 + * trans-expr.c (gfc_conv_function_call): Correctly dereference + argument from a pointer function also if it has a result clause. + +2005-03-04 Steven G. Kargl <kargls@comcast.net> + + * expr.c (gfc_copy_shape_excluding): Change && to ||. + +2005-03-04 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * trans-intrinsic.c (gfc_get_symbol_for_expr): Fix comment typo, + clarify comment. + +2005-02-28 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + (port from g95) + + PR fortran/19479 + * simplify.c (gfc_simplify_bound): Rename to ... + (simplify_bound): ... this and overhaul. + +2005-02-28 Steven G. Kargl <kargl@gcc.gnu.org> + + * trans-intrinsic.c (gfc_conv_intrinsic_iargc): remove boolean argument. + (gfc_conv_intrinsic_function): update function calls + +2005-02-27 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/20058 + * trans-types.c (gfc_max_integer_kind): Declare + (gfc_init_kinds): Initialize it. + * gfortran.h (gfc_max_integer_kind): extern it. + * primary.c (match_boz_constant): Use it; remove gfortran extension + of kind suffixes on BOZ literal constants + +2005-02-24 Volker Reichelt <reichelt@igpm.rwth-aachen.de> + + * decl.c, resolve.c, trans-array.c, trans.h: Fix comment typo(s). + +2005-04-24 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + Unrevert previously reverted patch. Adding this fix: + * module.c (find_true_name): Deal with NULL module. + +2005-02-24 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + Revert yesterday's patch: + 2005-02-23 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (gfc_component, gfc_actual_arglist, ... + ... argument. Copy string instead of pointing to it. + +2005-02-23 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (gfc_get_namespace): Add second argument to prototype. + * intrinsic.c (gfc_intrinsic_init_1): Pass second argument to + gfc_get_namespace. + * module.c (mio_namespace_ref, load_needed): Likewise. + * parse.c (parse_interface, parse_contained): Likewise. Here the + correct second argument matters. + * symbol.c (gfc_get_namespace): Add parent_types argument, only copy + parent's implicit types if this is set. + (gfc_symbol_init_2): Pass second argument to gfc_get_namespace. + * trans-common.c (build_common_decl): Likewise. + + * gfortran.h (symbol_attribute): New 'untyped' field, fix comment + formatting. + * symbol.c (gfc_set_default_type): Issue error only once, by setting + and checking 'untyped' attribute. + + * gfortran.h (gfc_expr): Move 'operator', 'op1', 'op2', and 'uop' + fields into new struct 'op' inside the 'value' union. + * arith.c (eval_intrinsic): Adapt all users. + * dependency.c (gfc_check_dependency): Likewise. + * dump-parse-tree.c (gfc_show_expr): Likewise. + * expr.c (gfc_get_expr): Don't clear removed fields. + (free_expr0, gfc_copy_expr, gfc_type_convert_binary, + gfc_is_constant_expr, simplify_intrinsic_op, check_init_expr, + check_intrinsic_op): Adapt to new field names. + * interface.c (gfc_extend_expr): Likewise. Also explicitly + nullify 'esym' and 'isym' fields of new function call. + * iresolve.c (gfc_resolve_dot_product, gfc_resolve_matmul): + Adapt to renamed structure fields. + * matchexp.c (build_node, match_level_1, match_expr): Likewise. + * module.c (mio_expr): Likewise. + * resolve.c (resolve_operator): Likewise. + (gfc_find_forall_index): Likewise. Only look through operands + if dealing with EXPR_OP + * trans-array.c (gfc_walk_op_expr): Adapt to renamed fields. + * trans-expr.c (gfc_conv_unary_op, gfc_conv_power_op, + gfc_conv_concat_op, gfc_conv_expr_op): Likewise. + + [ Reverted ] + * gfortran.h (gfc_component, gfc_actual_arglist, gfc_user_op): Make + 'name' a 'const char *'. + (gfc_symbol): Likewise, also for 'module'. + (gfc_symtree): Make 'name' a 'const char *'. + (gfc_intrinsic_sym): Likewise, also for 'lib_name'. + (gfc_get_gsymbol, gfc_find_gsymbol): Add 'const' qualifier to + 'char *' argument. + (gfc_intrinsic_symbol): Use 'gfc_get_string' instead of 'strcpy' to + initialize 'SYM->module'. + * check.c (gfc_check_minloc_maxloc, check_reduction): Check for NULL + pointer instead of empty string. + * dump-parse-tree.c (gfc_show_actual_arglist): Likewise. + * interface.c (gfc_compare_types): Adapt check to account for possible + NULL pointer. + (compare_actual_formal): Check for NULL pointer instead of empty + string. + * intrinsic.c (gfc_current_intrinsic, gfc_current_intrinsic_arg): + Add 'const' qualifier. + (conv_name): Return a heap allocated string. + (find_conv): Add 'const' qualifier to 'target'. + (add_sym): Use 'gfc_get_string' instead of 'strcpy'. + (make_generic): Check for NULL pointer instead of empty string. + (make_alias): Use 'gfc_get_string' instead of 'strcpy'. + (add_conv): No need to strcpy result from 'conv_name'. + (sort_actual): Check for NULL pointer instead of empty string. + * intrinsic.h (gfc_current_intrinsic, gfc_current_intrinsic_arg): + Adapt prototype. + * module.c (compare_true_names): Compare pointers instead of strings + for 'module' member. + (find_true_name): Initialize string fields with gfc_get_string. + (mio_pool_string): New function. + (mio_internal_string): Adapt comment. + (mio_component_ref, mio_component, mio_actual_arg): Use + 'mio_pool_string' instead of 'mio_internal_string'. + (mio_symbol_interface): Add 'const' qualifier to string arguments. + Add level of indirection. Use 'mio_pool_string' instead of + 'mio_internal_string'. + (load_needed, read_module): Use 'gfc_get_string' instead of 'strcpy'. + (write_common, write_symbol): Use 'mio_pool_string' instead of + 'mio_internal_string'. + (write_symbol0, write_symbol1): Likewise, also check for NULL pointer + instead of empty string. + (write_operator, write_generic): Pass correct type variable to + 'mio_symbol_interface'. + (write_symtree): Use 'mio_pool_string' instead of + 'mio_internal_string'. + * primary.c (match_keyword_arg): Adapt check to possible + case of NULL pointer. Use 'gfc_get_string' instead of 'strcpy'. + * symbol.c (gfc_add_component, gfc_new_symtree, delete_symtree, + gfc_get_uop, gfc_new_symbol): Use 'gfc_get_string' instead of + 'strcpy'. + (ambiguous_symbol): Check for NULL pointer instead of empty string. + (gfc_find_gsymbol, gfc_get_gsymbol): Add 'const' qualifier on string + arguments. + * trans-array.c (gfc_trans_auto_array_allocation): Check for NULL + pointer instead of empty string. + * trans-decl.c (gfc_sym_mangled_identifier, + gfc_sym_mangled_function_id, gfc_finish_var_decl, gfc_get_symbol_decl, + gfc_get_symbol_decl): Likewise. + * trans-io.c (gfc_new_nml_name_expr): Add 'const' qualifier to + argument. Copy string instead of pointing to it. + +2005-02-23 Kazu Hirata <kazu@cs.umass.edu> + + * intrinsic.h, st.c: Update copyright. + +2005-02-20 Steven G. Kargl <kargls@comcast.net> + + * symbol.c: Typos in comments. + +2005-02-20 Steven G. Kargl <kargls@comcast.net> + + * expr.c (gfc_type_convert_binary): Typo in comment. + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_selected_int_kind): New function. + * intrinsic.h: Prototype it. + * intrinsic.c (add_function): Use it. + * simplify (gfc_simplify_ceiling,gfc_simplify_floor): Change + BT_REAL to BT_INTEGER and use gfc_default_integer_kind. + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_int): improve checking of optional kind + * simplify.c (gfc_simplify_int): Change BT_REAL to BT_INTEGER + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_achar): New function + * intrinsic.h: Prototype it. + * intrinsic.c (add_function): Use it. + 2005-02-13 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> * trans-stmt.c (generate_loop_for_temp_to_lhs, diff --git a/gcc/fortran/ChangeLog.lno b/gcc/fortran/ChangeLog.lno new file mode 100644 index 00000000000..32ad9683ae5 --- /dev/null +++ b/gcc/fortran/ChangeLog.lno @@ -0,0 +1,2 @@ + * f95-lang.c (gfc_init_builtin_functions): Init + BUILT_IN_MAYBE_INFINITE_LOOP builtin. diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 924eea0fb2f..b55713e571e 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -152,9 +152,6 @@ gfc_arith_error (arith code) case ARITH_DIV0: p = "Division by zero"; break; - case ARITH_0TO0: - p = "Indeterminate form 0 ** 0"; - break; case ARITH_INCOMMENSURATE: p = "Array operands are incommensurate"; break; @@ -989,33 +986,23 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); if (power == 0) - { /* Handle something to the zeroth power */ + { + /* Handle something to the zeroth power. Since we're dealing + with integral exponents, there is no ambiguity in the + limiting procedure used to determine the value of 0**0. */ switch (op1->ts.type) { case BT_INTEGER: - if (mpz_sgn (op1->value.integer) == 0) - rc = ARITH_0TO0; - else - mpz_set_ui (result->value.integer, 1); + mpz_set_ui (result->value.integer, 1); break; case BT_REAL: - if (mpfr_sgn (op1->value.real) == 0) - rc = ARITH_0TO0; - else - mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); + mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); break; case BT_COMPLEX: - if (mpfr_sgn (op1->value.complex.r) == 0 - && mpfr_sgn (op1->value.complex.i) == 0) - rc = ARITH_0TO0; - else - { - mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); - mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); - } - + mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE); + mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE); break; default: @@ -1598,10 +1585,10 @@ eval_intrinsic (gfc_intrinsic_op operator, temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = operator; + temp.value.op.operator = operator; - temp.op1 = op1; - temp.op2 = op2; + temp.value.op.op1 = op1; + temp.value.op.op2 = op2; gfc_type_convert_binary (&temp); @@ -1671,10 +1658,10 @@ runtime: result->ts = temp.ts; result->expr_type = EXPR_OP; - result->operator = operator; + result->value.op.operator = operator; - result->op1 = op1; - result->op2 = op2; + result->value.op.op1 = op1; + result->value.op.op2 = op2; result->where = op1->where; diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 4f4f19b100b..dc660d45580 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1499,9 +1499,45 @@ resolve_array_list (gfc_constructor * p) return t; } +/* 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. */ -/* Resolve all of the expressions in an array list. - TODO: String lengths. */ +static void +resolve_character_array_constructor (gfc_expr * expr) +{ + gfc_constructor * p; + int max_length; + + gcc_assert (expr->expr_type == EXPR_ARRAY); + gcc_assert (expr->ts.type == BT_CHARACTER); + + max_length = -1; + + if (expr->ts.cl == NULL || expr->ts.cl->length == NULL) + { + /* Find the maximum length of the elements. Do nothing for variable array + constructor. */ + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->expr_type == EXPR_CONSTANT) + max_length = MAX (p->expr->value.character.length, max_length); + else + return; + + if (max_length != -1) + { + /* Update the character length of the array constructor. */ + if (expr->ts.cl == NULL) + expr->ts.cl = gfc_get_charlen (); + expr->ts.cl->length = gfc_int_expr (max_length); + /* Update the element constructors. */ + for (p = expr->value.constructor; p; p = p->next) + gfc_set_constant_character_len (max_length, p->expr); + } + } +} + +/* Resolve all of the expressions in an array list. */ try gfc_resolve_array_constructor (gfc_expr * expr) @@ -1511,6 +1547,8 @@ gfc_resolve_array_constructor (gfc_expr * expr) t = resolve_array_list (expr->value.constructor); if (t == SUCCESS) t = gfc_check_constructor_type (expr); + if (t == SUCCESS && expr->ts.type == BT_CHARACTER) + resolve_character_array_constructor (expr); return t; } diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a63112bd81e..8fae4449fbf 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -401,6 +401,16 @@ gfc_check_abs (gfc_expr * a) return SUCCESS; } +try +gfc_check_achar (gfc_expr * a) +{ + + if (type_check (a, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + try gfc_check_all_any (gfc_expr * mask, gfc_expr * dim) @@ -565,6 +575,35 @@ gfc_check_char (gfc_expr * i, gfc_expr * kind) try +gfc_check_chdir (gfc_expr * dir) +{ + if (type_check (dir, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status) +{ + if (type_check (dir, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind) { if (numeric_check (x, 0) == FAILURE) @@ -936,10 +975,18 @@ gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back) try gfc_check_int (gfc_expr * x, gfc_expr * kind) { - if (numeric_check (x, 0) == FAILURE - || kind_check (kind, 1, BT_INTEGER) == FAILURE) + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (kind != NULL) + { + if (type_check (kind, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (scalar_check (kind, 1) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -990,6 +1037,41 @@ gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size) try +gfc_check_kill (gfc_expr * pid, gfc_expr * sig) +{ + if (type_check (pid, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (sig, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status) +{ + if (type_check (pid, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (sig, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_kind (gfc_expr * x) { if (x->ts.type == BT_DERIVED) @@ -1021,6 +1103,76 @@ gfc_check_lbound (gfc_expr * array, gfc_expr * dim) try +gfc_check_link (gfc_expr * path1, gfc_expr * path2) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_logical (gfc_expr * a, gfc_expr * kind) { if (type_check (a, 0, BT_LOGICAL) == FAILURE) @@ -1196,7 +1348,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap) m = ap->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name[0] == '\0') + && ap->next->name == NULL) { m = d; d = NULL; @@ -1241,7 +1393,7 @@ check_reduction (gfc_actual_arglist * ap) m = ap->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name[0] == '\0') + && ap->next->name == NULL) { m = d; d = NULL; @@ -1436,6 +1588,41 @@ gfc_check_real (gfc_expr * a, gfc_expr * kind) try +gfc_check_rename (gfc_expr * path1, gfc_expr * path2) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status) +{ + if (type_check (path1, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (path2, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_repeat (gfc_expr * x, gfc_expr * y) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) @@ -1536,6 +1723,20 @@ gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z) try +gfc_check_selected_int_kind (gfc_expr * r) +{ + + if (type_check (r, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (r, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r) { if (p == NULL && r == NULL) @@ -1626,6 +1827,19 @@ gfc_check_size (gfc_expr * array, gfc_expr * dim) try +gfc_check_sleep_sub (gfc_expr * seconds) +{ + if (type_check (seconds, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (seconds, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) @@ -2202,6 +2416,16 @@ gfc_check_etime_sub (gfc_expr * values, gfc_expr * time) try +gfc_check_gerror (gfc_expr * msg) +{ + if (type_check (msg, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status) { if (type_check (cwd, 0, BT_CHARACTER) == FAILURE) @@ -2221,6 +2445,16 @@ gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status) try +gfc_check_getlog (gfc_expr * msg) +{ + if (type_check (msg, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_exit (gfc_expr * status) { if (status == NULL) @@ -2253,6 +2487,45 @@ gfc_check_flush (gfc_expr * unit) try +gfc_check_hostnm (gfc_expr * name) +{ + if (type_check (name, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status) +{ + if (type_check (name, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (scalar_check (status, 1) == FAILURE) + return FAILURE; + + if (type_check (status, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_perror (gfc_expr * string) +{ + if (type_check (string, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_umask (gfc_expr * mask) { if (type_check (mask, 0, BT_INTEGER) == FAILURE) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9ad5ef17973..f2d8d74856d 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -27,7 +27,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "parse.h" -/* This flag is set if a an old-style length selector is matched +/* This flag is set if an old-style length selector is matched during a type-declaration statement. */ static int old_char_selector; @@ -646,6 +646,30 @@ build_sym (const char *name, gfc_charlen * cl, return SUCCESS; } +/* Set character constant to the given length. The constant will be padded or + truncated. */ + +void +gfc_set_constant_character_len (int len, gfc_expr * expr) +{ + char * s; + int slen; + + gcc_assert (expr->expr_type == EXPR_CONSTANT); + gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); + + slen = expr->value.character.length; + if (len != slen) + { + s = gfc_getmem (len); + memcpy (s, expr->value.character.string, MIN (len, slen)); + if (len > slen) + memset (&s[slen], ' ', len - slen); + gfc_free (expr->value.character.string); + expr->value.character.string = s; + expr->value.character.length = len; + } +} /* Function called by variable_decl() that adds an initialization expression to a symbol. */ @@ -711,6 +735,35 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp, && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; + if (sym->ts.type == BT_CHARACTER && sym->ts.cl) + { + /* Update symbol character length according initializer. */ + if (sym->ts.cl->length == NULL) + { + if (init->expr_type == EXPR_CONSTANT) + sym->ts.cl->length = + gfc_int_expr (init->value.character.length); + else if (init->expr_type == EXPR_ARRAY) + sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length); + } + /* Update initializer character length according symbol. */ + else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT) + { + int len = mpz_get_si (sym->ts.cl->length->value.integer); + gfc_constructor * p; + + if (init->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (len, init); + else if (init->expr_type == EXPR_ARRAY) + { + gfc_free_expr (init->ts.cl->length); + init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length); + for (p = init->value.constructor; p; p = p->next) + gfc_set_constant_character_len (len, p->expr); + } + } + } + /* Add initializer. Make sure we keep the ranks sane. */ if (sym->attr.dimension && init->rank == 0) init->rank = sym->as->rank; diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index fb0c5764d45..cb5cb50fd92 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -277,11 +277,11 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars, switch (expr2->expr_type) { case EXPR_OP: - n = gfc_check_dependency (expr1, expr2->op1, vars, nvars); + n = gfc_check_dependency (expr1, expr2->value.op.op1, vars, nvars); if (n) return n; - if (expr2->op2) - return gfc_check_dependency (expr1, expr2->op2, vars, nvars); + if (expr2->value.op.op2) + return gfc_check_dependency (expr1, expr2->value.op.op2, vars, nvars); return 0; case EXPR_VARIABLE: diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7af7a625f65..3df244cca71 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -106,7 +106,7 @@ gfc_show_actual_arglist (gfc_actual_arglist * a) for (; a; a = a->next) { gfc_status_char ('('); - if (a->name[0] != '\0') + if (a->name != NULL) gfc_status ("%s = ", a->name); if (a->expr != NULL) gfc_show_expr (a->expr); @@ -409,13 +409,15 @@ gfc_show_expr (gfc_expr * p) break; case EXPR_VARIABLE: + if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) + gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name); gfc_status ("%s", p->symtree->n.sym->name); gfc_show_ref (p->ref); break; case EXPR_OP: gfc_status ("("); - switch (p->operator) + switch (p->value.op.operator) { case INTRINSIC_UPLUS: gfc_status ("U+ "); @@ -480,12 +482,12 @@ gfc_show_expr (gfc_expr * p) ("gfc_show_expr(): Bad intrinsic in expression!"); } - gfc_show_expr (p->op1); + gfc_show_expr (p->value.op.op1); - if (p->op2) + if (p->value.op.op2) { gfc_status (" "); - gfc_show_expr (p->op2); + gfc_show_expr (p->value.op.op2); } gfc_status (")"); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3898f7afd63..d0c99e335a0 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -36,12 +36,9 @@ gfc_get_expr (void) e = gfc_getmem (sizeof (gfc_expr)); gfc_clear_ts (&e->ts); - e->op1 = NULL; - e->op2 = NULL; e->shape = NULL; e->ref = NULL; e->symtree = NULL; - e->uop = NULL; return e; } @@ -170,10 +167,10 @@ free_expr0 (gfc_expr * e) break; case EXPR_OP: - if (e->op1 != NULL) - gfc_free_expr (e->op1); - if (e->op2 != NULL) - gfc_free_expr (e->op2); + if (e->value.op.op1 != NULL) + gfc_free_expr (e->value.op.op1); + if (e->value.op.op2 != NULL) + gfc_free_expr (e->value.op.op2); break; case EXPR_FUNCTION: @@ -355,7 +352,7 @@ gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim) n = mpz_get_si (dim->value.integer); n--; /* Convert to zero based index */ - if (n < 0 && n >= rank) + if (n < 0 || n >= rank) return NULL; s = new_shape = gfc_get_shape (rank-1); @@ -437,17 +434,17 @@ gfc_copy_expr (gfc_expr * p) break; case EXPR_OP: - switch (q->operator) + switch (q->value.op.operator) { case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - q->op1 = gfc_copy_expr (p->op1); + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); break; default: /* Binary operators */ - q->op1 = gfc_copy_expr (p->op1); - q->op2 = gfc_copy_expr (p->op2); + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); break; } @@ -584,8 +581,8 @@ gfc_type_convert_binary (gfc_expr * e) { gfc_expr *op1, *op2; - op1 = e->op1; - op2 = e->op2; + op1 = e->value.op.op1; + op2 = e->value.op.op2; if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) { @@ -618,18 +615,18 @@ gfc_type_convert_binary (gfc_expr * e) { e->ts = op1->ts; - /* Special cose for ** operator. */ - if (e->operator == INTRINSIC_POWER) + /* Special case for ** operator. */ + if (e->value.op.operator == INTRINSIC_POWER) goto done; - gfc_convert_type (e->op2, &e->ts, 2); + gfc_convert_type (e->value.op.op2, &e->ts, 2); goto done; } if (op1->ts.type == BT_INTEGER) { e->ts = op2->ts; - gfc_convert_type (e->op1, &e->ts, 2); + gfc_convert_type (e->value.op.op1, &e->ts, 2); goto done; } @@ -640,9 +637,9 @@ gfc_type_convert_binary (gfc_expr * e) else e->ts.kind = op2->ts.kind; if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) - gfc_convert_type (e->op1, &e->ts, 2); + gfc_convert_type (e->value.op.op1, &e->ts, 2); if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) - gfc_convert_type (e->op2, &e->ts, 2); + gfc_convert_type (e->value.op.op2, &e->ts, 2); done: return; @@ -665,9 +662,9 @@ gfc_is_constant_expr (gfc_expr * e) switch (e->expr_type) { case EXPR_OP: - rv = (gfc_is_constant_expr (e->op1) - && (e->op2 == NULL - || gfc_is_constant_expr (e->op2))); + rv = (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); break; @@ -729,11 +726,11 @@ simplify_intrinsic_op (gfc_expr * p, int type) { gfc_expr *op1, *op2, *result; - if (p->operator == INTRINSIC_USER) + if (p->value.op.operator == INTRINSIC_USER) return SUCCESS; - op1 = p->op1; - op2 = p->op2; + op1 = p->value.op.op1; + op2 = p->value.op.op2; if (gfc_simplify_expr (op1, type) == FAILURE) return FAILURE; @@ -745,10 +742,10 @@ simplify_intrinsic_op (gfc_expr * p, int type) return SUCCESS; /* Rip p apart */ - p->op1 = NULL; - p->op2 = NULL; + p->value.op.op1 = NULL; + p->value.op.op2 = NULL; - switch (p->operator) + switch (p->value.op.operator) { case INTRINSIC_UPLUS: result = gfc_uplus (op1); @@ -1191,15 +1188,17 @@ static try check_init_expr (gfc_expr *); static try check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) { + gfc_expr *op1 = e->value.op.op1; + gfc_expr *op2 = e->value.op.op2; - if ((*check_function) (e->op1) == FAILURE) + if ((*check_function) (op1) == FAILURE) return FAILURE; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - if (!numeric_type (et0 (e->op1))) + if (!numeric_type (et0 (op1))) goto not_numeric; break; @@ -1209,11 +1208,11 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_GE: case INTRINSIC_LT: case INTRINSIC_LE: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (!(et0 (e->op1) == BT_CHARACTER && et0 (e->op2) == BT_CHARACTER) - && !(numeric_type (et0 (e->op1)) && numeric_type (et0 (e->op2)))) + if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) + && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) { gfc_error ("Numeric or CHARACTER operands are required in " "expression at %L", &e->where); @@ -1226,34 +1225,34 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: case INTRINSIC_POWER: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2))) + if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) goto not_numeric; - if (e->operator == INTRINSIC_POWER - && check_function == check_init_expr && et0 (e->op2) != BT_INTEGER) + if (e->value.op.operator == INTRINSIC_POWER + && check_function == check_init_expr && et0 (op2) != BT_INTEGER) { gfc_error ("Exponent at %L must be INTEGER for an initialization " - "expression", &e->op2->where); + "expression", &op2->where); return FAILURE; } break; case INTRINSIC_CONCAT: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (et0 (e->op1) != BT_CHARACTER || et0 (e->op2) != BT_CHARACTER) + if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) { gfc_error ("Concatenation operator in expression at %L " - "must have two CHARACTER operands", &e->op1->where); + "must have two CHARACTER operands", &op1->where); return FAILURE; } - if (e->op1->ts.kind != e->op2->ts.kind) + if (op1->ts.kind != op2->ts.kind) { gfc_error ("Concat operator at %L must concatenate strings of the " "same kind", &e->where); @@ -1263,10 +1262,10 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) break; case INTRINSIC_NOT: - if (et0 (e->op1) != BT_LOGICAL) + if (et0 (op1) != BT_LOGICAL) { gfc_error (".NOT. operator in expression at %L must have a LOGICAL " - "operand", &e->op1->where); + "operand", &op1->where); return FAILURE; } @@ -1276,10 +1275,10 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (et0 (e->op1) != BT_LOGICAL || et0 (e->op2) != BT_LOGICAL) + if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) { gfc_error ("LOGICAL operands are required in expression at %L", &e->where); @@ -1790,11 +1789,12 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform) return FAILURE; } - /* This is a guaranteed segfault and possibly a typo: p = NULL() - instead of p => NULL() */ - if (rvalue->expr_type == EXPR_NULL) - gfc_warning ("NULL appears on right-hand side in assignment at %L", - &rvalue->where); + if (rvalue->expr_type == EXPR_NULL) + { + gfc_error ("NULL appears on right-hand side in assignment at %L", + &rvalue->where); + return FAILURE; + } /* This is possibly a typo: x = f() instead of x => f() */ if (gfc_option.warn_surprising diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 7f04b7ca261..4f3b4e1543d 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -145,6 +145,22 @@ static void gfc_expand_function (tree); const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; +/* APPLE LOCAL begin constant cfstrings */ +enum { blabla } c_language; +const char *constant_string_class_name = "die die"; +int flag_next_runtime = 1; +/* APPLE LOCAL end constant cfstrings */ + +/* APPLE LOCAL disable_typechecking_for_spec_flag */ +int disable_typechecking_for_spec_flag = 0; + +/* APPLE LOCAL begin CW asm blocks */ +/* Dummies needed because we use them from cpplib, yuck. */ +int flag_cw_asm_blocks; +int cw_asm_state; +int cw_asm_in_operands; +/* APPLE LOCAL end CW asm blocks */ + /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function that have names. Here so we can clear out their names' definitions at the end of the function. */ @@ -828,6 +844,12 @@ gfc_init_builtin_functions (void) ftype = build_function_type (long_integer_type_node, tmp); gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, "__builtin_expect", true); + /* APPLE LOCAL begin lno */ + ftype = build_function_type (void_type_node, void_list_node); + gfc_define_builtin ("__builtin_maybe_infinite_loop", ftype, + BUILT_IN_MAYBE_INFINITE_LOOP, "maybe_infinite_loop", + false); + /* APPLE LOCAL end lno */ build_common_builtin_nodes (); targetm.init_builtins (); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9df2f376ed3..1e56920c73c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -181,7 +181,7 @@ extern mstring intrinsic_operators[]; /* Arithmetic results. */ typedef enum { ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN, - ARITH_DIV0, ARITH_0TO0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC + ARITH_DIV0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC } arith; @@ -292,6 +292,7 @@ enum gfc_generic_isym_id GFC_ISYM_BTEST, GFC_ISYM_CEILING, GFC_ISYM_CHAR, + GFC_ISYM_CHDIR, GFC_ISYM_CMPLX, GFC_ISYM_COMMAND_ARGUMENT_COUNT, GFC_ISYM_CONJG, @@ -317,6 +318,7 @@ enum gfc_generic_isym_id GFC_ISYM_GETGID, GFC_ISYM_GETPID, GFC_ISYM_GETUID, + GFC_ISYM_HOSTNM, GFC_ISYM_IACHAR, GFC_ISYM_IAND, GFC_ISYM_IARGC, @@ -325,15 +327,18 @@ enum gfc_generic_isym_id GFC_ISYM_IBSET, GFC_ISYM_ICHAR, GFC_ISYM_IEOR, + GFC_ISYM_IERRNO, GFC_ISYM_INDEX, GFC_ISYM_INT, GFC_ISYM_IOR, GFC_ISYM_IRAND, GFC_ISYM_ISHFT, GFC_ISYM_ISHFTC, + GFC_ISYM_KILL, GFC_ISYM_LBOUND, GFC_ISYM_LEN, GFC_ISYM_LEN_TRIM, + GFC_ISYM_LINK, GFC_ISYM_LGE, GFC_ISYM_LGT, GFC_ISYM_LLE, @@ -359,6 +364,7 @@ enum gfc_generic_isym_id GFC_ISYM_PRODUCT, GFC_ISYM_RAND, GFC_ISYM_REAL, + GFC_ISYM_RENAME, GFC_ISYM_REPEAT, GFC_ISYM_RESHAPE, GFC_ISYM_RRSPACING, @@ -378,9 +384,12 @@ enum gfc_generic_isym_id GFC_ISYM_SR_KIND, GFC_ISYM_STAT, GFC_ISYM_SUM, + GFC_ISYM_SYMLNK, GFC_ISYM_SYSTEM, GFC_ISYM_TAN, GFC_ISYM_TANH, + GFC_ISYM_TIME, + GFC_ISYM_TIME8, GFC_ISYM_TRANSFER, GFC_ISYM_TRANSPOSE, GFC_ISYM_TRIM, @@ -408,7 +417,8 @@ typedef struct unsigned in_namelist:1, in_common:1; unsigned function:1, subroutine:1, generic:1; - unsigned implicit_type:1; /* Type defined via implicit rules */ + unsigned implicit_type:1; /* Type defined via implicit rules. */ + unsigned untyped:1; /* No implicit type could be found. */ /* Function/subroutine attributes */ unsigned sequence:1, elemental:1, pure:1, recursive:1; @@ -539,7 +549,7 @@ gfc_array_spec; /* Components of derived types. */ typedef struct gfc_component { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; gfc_typespec ts; int pointer, dimension; @@ -570,7 +580,7 @@ gfc_formal_arglist; /* The gfc_actual_arglist structure is for actual arguments. */ typedef struct gfc_actual_arglist { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; /* Alternate return label when the expr member is null. */ struct gfc_st_label *label; @@ -635,7 +645,7 @@ gfc_interface; /* User operator nodes. These are like stripped down symbols. */ typedef struct { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; gfc_interface *operator; struct gfc_namespace *ns; @@ -651,8 +661,8 @@ gfc_user_op; typedef struct gfc_symbol { - char name[GFC_MAX_SYMBOL_LEN + 1]; /* Primary name, before renaming */ - char module[GFC_MAX_SYMBOL_LEN + 1]; /* Module this symbol came from */ + const char *name; /* Primary name, before renaming */ + const char *module; /* Module this symbol came from */ locus declared_at; gfc_typespec ts; @@ -743,7 +753,7 @@ gfc_entry_list; typedef struct gfc_symtree { BBT_HEADER (gfc_symtree); - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; int ambiguous; union { @@ -1002,7 +1012,7 @@ gfc_resolve_f; typedef struct gfc_intrinsic_sym { - char name[GFC_MAX_SYMBOL_LEN + 1], lib_name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name, *lib_name; gfc_intrinsic_arg *formal; gfc_typespec ts; int elemental, pure, generic, specific, actual_ok, standard; @@ -1043,15 +1053,11 @@ typedef struct gfc_expr int rank; mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ - gfc_intrinsic_op operator; - /* Nonnull for functions and structure constructors */ gfc_symtree *symtree; - gfc_user_op *uop; gfc_ref *ref; - struct gfc_expr *op1, *op2; locus where; union @@ -1069,6 +1075,14 @@ typedef struct gfc_expr struct { + gfc_intrinsic_op operator; + gfc_user_op *uop; + struct gfc_expr *op1, *op2; + } + op; + + struct + { gfc_actual_arglist *actual; const char *name; /* Points to the ultimate name of the function */ gfc_intrinsic_sym *isym; @@ -1388,6 +1402,9 @@ typedef struct int warn_surprising; int warn_unused_labels; + int flag_default_double; + int flag_default_integer; + int flag_default_real; int flag_dollar_ok; int flag_underscoring; int flag_second_underscore; @@ -1399,9 +1416,7 @@ typedef struct int flag_repack_arrays; int q_kind; - int r8; - int i8; - int d8; + int warn_std; int allow_std; int warn_nonstd_intrinsics; @@ -1551,6 +1566,7 @@ void gfc_arith_done_1 (void); int gfc_validate_kind (bt, int, bool); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; +extern int gfc_max_integer_kind; extern int gfc_default_real_kind; extern int gfc_default_double_kind; extern int gfc_default_character_kind; @@ -1619,7 +1635,7 @@ void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); try gfc_reference_st_label (gfc_st_label *, gfc_sl_type); -gfc_namespace *gfc_get_namespace (gfc_namespace *); +gfc_namespace *gfc_get_namespace (gfc_namespace *, int); gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *); gfc_user_op *gfc_get_uop (const char *); @@ -1649,8 +1665,8 @@ void gfc_save_all (gfc_namespace *); void gfc_symbol_state (void); -gfc_gsymbol *gfc_get_gsymbol (char *); -gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, char *); +gfc_gsymbol *gfc_get_gsymbol (const char *); +gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); /* intrinsic.c */ extern int gfc_init_expr; @@ -1659,7 +1675,7 @@ extern int gfc_init_expr; by placing it into a special module that is otherwise impossible to read or write. */ -#define gfc_intrinsic_symbol(SYM) strcpy (SYM->module, "(intrinsic)") +#define gfc_intrinsic_symbol(SYM) SYM->module = gfc_get_string ("(intrinsic)") void gfc_intrinsic_init_1 (void); void gfc_intrinsic_done_1 (void); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index c3242f7b5a3..9068cffdc76 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -109,25 +109,31 @@ the GNU Fortran 95 compiler. You can find in this manual how to invoke @ifset DEVELOPMENT @emph{Warning:} This document, and the compiler it describes, are still -under development. While efforts are made too keep it up-to-date it might +under development. While efforts are made to keep it up-to-date, it might not accurately reflect the status of the most recent @command{gfortran}. @end ifset +@comment +@comment When you add a new menu item, please keep the right hand +@comment aligned to the same column. Do not use tabs. This provides +@comment better formatting. +@comment @menu -* Copying:: GNU General Public License says - how you can copy and share GNU Fortran. +* Copying:: GNU General Public License says + how you can copy and share GNU Fortran. * GNU Free Documentation License:: - How you can copy and share this manual. -* Funding:: How to help assure continued work for free software. -* Getting Started:: What you should know about @command{gfortran}. -* GFORTRAN and GCC:: You can compile Fortran, C, or other programs. -* GFORTRAN and G77:: Why we choose to start from scratch. + How you can copy and share this manual. +* Funding:: How to help assure continued work for free software. +* Getting Started:: What you should know about @command{gfortran}. +* GFORTRAN and GCC:: You can compile Fortran, C, or other programs. +* GFORTRAN and G77:: Why we chose to start from scratch. * Invoking GFORTRAN:: Command options supported by @command{gfortran}. -* Project Status:: Status of @command{gfortran}, Roadmap, proposed extensions. -* Contributing:: Helping you can help. -* Standards:: Standards supported by @command{gfortran} -* Extensions:: Language extensions implemented by @command{gfortran} -* Index:: Index of this documentation. +* Project Status:: Status of @command{gfortran}, roadmap, proposed extensions. +* Contributing:: How you can help. +* Standards:: Standards supported by @command{gfortran} +* Extensions:: Language extensions implemented by @command{gfortran} +* Intrinsic Procedures:: Intrinsic procedures supported by @command{gfortran} +* Index:: Index of this documentation. @end menu @@ -369,7 +375,6 @@ because it was expected to be easier to maintain code we develop ourselves than to do a major overhaul of @command{g77} first, and then build a Fortran 95 compiler out of it. - @include invoke.texi @c --------------------------------------------------------------------- @@ -670,6 +675,7 @@ Examples of standard conforming code equivalent to the above example, are: DATA i,j,x /1,2,3*0.,1./ @end smallexample +@include intrinsic.texi @c --------------------------------------------------------------------- @c Contributing @c --------------------------------------------------------------------- diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 71555e48cbe..ecbf9a27aac 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -340,8 +340,9 @@ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) true names and module names are the same and the module name is nonnull, then they are equal. */ if (strcmp (ts1->derived->name, ts2->derived->name) == 0 - && ts1->derived->module[0] != '\0' - && strcmp (ts1->derived->module, ts2->derived->module) == 0) + && ((ts1->derived->module == NULL && ts2->derived->module == NULL) + || (ts1->derived != NULL && ts2->derived != NULL + && strcmp (ts1->derived->module, ts2->derived->module) == 0))) return 1; /* Compare type via the rules of the standard. Both types must have @@ -1165,7 +1166,7 @@ compare_actual_formal (gfc_actual_arglist ** ap, for (a = actual; a; a = a->next, f = f->next) { - if (a->name[0] != '\0') + if (a->name != NULL) { i = 0; for (f = formal; f; f = f->next, i++) @@ -1640,21 +1641,21 @@ gfc_extend_expr (gfc_expr * e) sym = NULL; actual = gfc_get_actual_arglist (); - actual->expr = e->op1; + actual->expr = e->value.op.op1; - if (e->op2 != NULL) + if (e->value.op.op2 != NULL) { actual->next = gfc_get_actual_arglist (); - actual->next->expr = e->op2; + actual->next->expr = e->value.op.op2; } - i = fold_unary (e->operator); + i = fold_unary (e->value.op.operator); if (i == INTRINSIC_USER) { for (ns = gfc_current_ns; ns; ns = ns->parent) { - uop = gfc_find_uop (e->uop->name, ns); + uop = gfc_find_uop (e->value.op.uop->name, ns); if (uop == NULL) continue; @@ -1687,6 +1688,8 @@ gfc_extend_expr (gfc_expr * e) e->expr_type = EXPR_FUNCTION; e->symtree = find_sym_in_symtree (sym); e->value.function.actual = actual; + e->value.function.esym = NULL; + e->value.function.isym = NULL; if (gfc_pure (NULL) && !gfc_pure (sym)) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 03d443f3c52..7336e63d552 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -37,7 +37,8 @@ int gfc_init_expr = 0; /* Pointers to an intrinsic function and its argument names that are being checked. */ -char *gfc_current_intrinsic, *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +const char *gfc_current_intrinsic; +const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; @@ -107,7 +108,7 @@ gfc_get_intrinsic_sub_symbol (const char * name) /* Return a pointer to the name of a conversion function given two typespecs. */ -static char * +static const char * conv_name (gfc_typespec * from, gfc_typespec * to) { static char name[30]; @@ -115,7 +116,7 @@ conv_name (gfc_typespec * from, gfc_typespec * to) sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type), from->kind, gfc_type_letter (to->type), to->kind); - return name; + return gfc_get_string (name); } @@ -127,7 +128,7 @@ static gfc_intrinsic_sym * find_conv (gfc_typespec * from, gfc_typespec * to) { gfc_intrinsic_sym *sym; - char *target; + const char *target; int i; target = conv_name (from, to); @@ -213,7 +214,7 @@ add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED, bt type, int kind, int standard, gfc_check_f check, gfc_simplify_f simplify, gfc_resolve_f resolve, ...) { - + char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */ int optional, first_flag; va_list argp; @@ -233,10 +234,11 @@ add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED, break; case SZ_NOTHING: - strcpy (next_sym->name, name); + next_sym->name = gfc_get_string (name); - strcpy (next_sym->lib_name, "_gfortran_"); - strcat (next_sym->lib_name, name); + strcpy (buf, "_gfortran_"); + strcat (buf, name); + next_sym->lib_name = gfc_get_string (buf); next_sym->elemental = elemental; next_sym->ts.type = type; @@ -785,11 +787,11 @@ make_generic (const char *name, gfc_generic_isym_id generic_id, int standard) g->generic = 1; g->specific = 1; g->generic_id = generic_id; - if ((g + 1)->name[0] != '\0') + if ((g + 1)->name != NULL) g->specific_head = g + 1; g++; - while (g->name[0] != '\0') + while (g->name != NULL) { g->next = g + 1; g->specific = 1; @@ -828,7 +830,7 @@ make_alias (const char *name, int standard) case SZ_NOTHING: next_sym[0] = next_sym[-1]; - strcpy (next_sym->name, name); + next_sym->name = gfc_get_string (name); next_sym++; break; @@ -894,7 +896,7 @@ add_functions (void) make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77); add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_achar, NULL, + gfc_check_achar, gfc_simplify_achar, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); @@ -1090,6 +1092,12 @@ add_functions (void) make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77); + add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_chdir, NULL, gfc_resolve_chdir, + a, BT_CHARACTER, dc, REQUIRED); + + make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU); + add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77, gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx, x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL, @@ -1321,6 +1329,12 @@ add_functions (void) make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU); + add_sym_1 ("hostnm", 0, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_hostnm, NULL, gfc_resolve_hostnm, + a, BT_CHARACTER, dc, REQUIRED); + + make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU); + add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95, gfc_check_huge, gfc_simplify_huge, NULL, x, BT_UNKNOWN, dr, REQUIRED); @@ -1381,6 +1395,11 @@ add_functions (void) make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); + add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU, + NULL, NULL, gfc_resolve_ierrno); + + make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); + add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77, gfc_check_index, gfc_simplify_index, NULL, stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, @@ -1428,6 +1447,12 @@ add_functions (void) make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95); + add_sym_2 ("kill", 1, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_kill, NULL, gfc_resolve_kill, + a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED); + + make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU); + add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95, gfc_check_kind, gfc_simplify_kind, NULL, x, BT_REAL, dr, REQUIRED); @@ -1450,6 +1475,8 @@ add_functions (void) NULL, gfc_simplify_len_trim, gfc_resolve_len_trim, stg, BT_CHARACTER, dc, REQUIRED); + make_alias ("lnblnk", GFC_STD_GNU); + make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95); add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77, @@ -1476,6 +1503,12 @@ add_functions (void) make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); + add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_link, NULL, gfc_resolve_link, + a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED); + + make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU); + add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77, gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, REQUIRED); @@ -1742,6 +1775,12 @@ add_functions (void) make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77); + add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_rename, NULL, gfc_resolve_rename, + a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED); + + make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU); + add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95, gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED); @@ -1781,7 +1820,7 @@ add_functions (void) make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, GFC_STD_F95, - NULL, gfc_simplify_selected_int_kind, NULL, + gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); @@ -1902,6 +1941,12 @@ add_functions (void) make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95); + add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_symlnk, NULL, gfc_resolve_symlnk, + a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED); + + make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU); + add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, NULL, c, BT_CHARACTER, dc, REQUIRED); @@ -1928,6 +1973,16 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); + add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU, + NULL, NULL, gfc_resolve_time); + + make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU); + + add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU, + NULL, NULL, gfc_resolve_time8); + + make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU); + add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95, gfc_check_x, gfc_simplify_tiny, NULL, x, BT_REAL, dr, REQUIRED); @@ -2022,6 +2077,10 @@ add_subroutines (void) gfc_check_second_sub, NULL, gfc_resolve_second_sub, tm, BT_REAL, dr, REQUIRED); + add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub, + name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL, @@ -2036,6 +2095,10 @@ add_subroutines (void) gfc_check_etime_sub, NULL, gfc_resolve_etime_sub, vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED); + add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER, + dc, REQUIRED); + add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); @@ -2048,6 +2111,10 @@ add_subroutines (void) NULL, NULL, gfc_resolve_getarg, c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED); + add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER, + dc, REQUIRED); + /* F2003 commandline routines. */ add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003, @@ -2096,6 +2163,32 @@ add_subroutines (void) gfc_check_flush, NULL, gfc_resolve_flush, c, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, + c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + + add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub, + NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED, + val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + + add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_link_sub, NULL, gfc_resolve_link_sub, + name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, + dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + + add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_perror, NULL, gfc_resolve_perror, + c, BT_CHARACTER, dc, REQUIRED); + + add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, + name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, + dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + + add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, + val, BT_CHARACTER, dc, REQUIRED); + add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED, @@ -2106,6 +2199,11 @@ add_subroutines (void) name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, + name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, + dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); @@ -2152,8 +2250,8 @@ add_conv (bt from_type, int from_kind, bt to_type, int to_kind, sym = conversion + nconv; - strcpy (sym->name, conv_name (&from, &to)); - strcpy (sym->lib_name, sym->name); + sym->name = conv_name (&from, &to); + sym->lib_name = sym->name; sym->simplify.cc = simplify; sym->elemental = 1; sym->ts = to; @@ -2241,7 +2339,7 @@ gfc_intrinsic_init_1 (void) nargs = nfunc = nsub = nconv = 0; /* Create a namespace to hold the resolved intrinsic symbols. */ - gfc_intrinsic_namespace = gfc_get_namespace (NULL); + gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0); sizing = SZ_FUNCS; add_functions (); @@ -2359,7 +2457,7 @@ sort_actual (const char *name, gfc_actual_arglist ** ap, if (a == NULL) goto optional; - if (a->name[0] != '\0') + if (a->name != NULL) goto keywords; f->actual = a; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 41593efe9c1..bf2c80a0c7e 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -1,6 +1,7 @@ /* Header file for intrinsics check, resolve and simplify function prototypes. - Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 + Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -31,6 +32,7 @@ try gfc_check_a_xkind (gfc_expr *, gfc_expr *); try gfc_check_a_p (gfc_expr *, gfc_expr *); try gfc_check_abs (gfc_expr *); +try gfc_check_achar (gfc_expr *); try gfc_check_all_any (gfc_expr *, gfc_expr *); try gfc_check_allocated (gfc_expr *); try gfc_check_associated (gfc_expr *, gfc_expr *); @@ -38,6 +40,7 @@ try gfc_check_atan2 (gfc_expr *, gfc_expr *); try gfc_check_besn (gfc_expr *, gfc_expr *); try gfc_check_btest (gfc_expr *, gfc_expr *); try gfc_check_char (gfc_expr *, gfc_expr *); +try gfc_check_chdir (gfc_expr *); try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_count (gfc_expr *, gfc_expr *); try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *); @@ -53,6 +56,7 @@ try gfc_check_fn_r (gfc_expr *); try gfc_check_fn_rc (gfc_expr *); try gfc_check_fnum (gfc_expr *); try gfc_check_g77_math1 (gfc_expr *); +try gfc_check_hostnm (gfc_expr *); try gfc_check_huge (gfc_expr *); try gfc_check_i (gfc_expr *); try gfc_check_iand (gfc_expr *, gfc_expr *); @@ -67,8 +71,10 @@ try gfc_check_ior (gfc_expr *, gfc_expr *); try gfc_check_irand (gfc_expr *); try gfc_check_ishft (gfc_expr *, gfc_expr *); try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_kill (gfc_expr *, gfc_expr *); try gfc_check_kind (gfc_expr *); try gfc_check_lbound (gfc_expr *, gfc_expr *); +try gfc_check_link (gfc_expr *, gfc_expr *); try gfc_check_logical (gfc_expr *, gfc_expr *); try gfc_check_min_max (gfc_actual_arglist *); try gfc_check_min_max_integer (gfc_actual_arglist *); @@ -88,11 +94,13 @@ try gfc_check_radix (gfc_expr *); try gfc_check_rand (gfc_expr *); try gfc_check_range (gfc_expr *); try gfc_check_real (gfc_expr *, gfc_expr *); +try gfc_check_rename (gfc_expr *, gfc_expr *); try gfc_check_repeat (gfc_expr *, gfc_expr *); try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_scale (gfc_expr *, gfc_expr *); try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_second_sub (gfc_expr *); +try gfc_check_selected_int_kind (gfc_expr *); try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); try gfc_check_set_exponent (gfc_expr *, gfc_expr *); try gfc_check_shape (gfc_expr *); @@ -102,6 +110,7 @@ try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_srand (gfc_expr *); try gfc_check_stat (gfc_expr *, gfc_expr *); try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_symlnk (gfc_expr *, gfc_expr *); try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_transpose (gfc_expr *); try gfc_check_trim (gfc_expr *); @@ -114,18 +123,28 @@ try gfc_check_x (gfc_expr *); /* Intrinsic subroutines. */ +try gfc_check_chdir_sub (gfc_expr *, gfc_expr *); try gfc_check_cpu_time (gfc_expr *); try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_exit (gfc_expr *); try gfc_check_flush (gfc_expr *); try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_gerror (gfc_expr *); +try gfc_check_getlog (gfc_expr *); try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_random_number (gfc_expr *); try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_etime_sub (gfc_expr *, gfc_expr *); try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); +try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); +try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_perror (gfc_expr *); +try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_sleep_sub (gfc_expr *); try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_system_sub (gfc_expr *, gfc_expr *); try gfc_check_umask_sub (gfc_expr *, gfc_expr *); @@ -253,6 +272,7 @@ void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_chdir (gfc_expr *, gfc_expr *); void gfc_resolve_cmplx (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_dcmplx (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_conjg (gfc_expr *, gfc_expr *); @@ -278,10 +298,12 @@ void gfc_resolve_getcwd (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); void gfc_resolve_getuid (gfc_expr *); +void gfc_resolve_hostnm (gfc_expr *, gfc_expr *); void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ichar (gfc_expr *, gfc_expr *); void gfc_resolve_idnint (gfc_expr *, gfc_expr *); @@ -289,9 +311,11 @@ void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_len (gfc_expr *, gfc_expr *); void gfc_resolve_len_trim (gfc_expr *, gfc_expr *); +void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_log (gfc_expr *, gfc_expr *); void gfc_resolve_log10 (gfc_expr *, gfc_expr *); void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *); @@ -311,6 +335,7 @@ void gfc_resolve_not (gfc_expr *, gfc_expr *); void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -329,9 +354,12 @@ void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_srand (gfc_code *); void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_system (gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tanh (gfc_expr *, gfc_expr *); +void gfc_resolve_time (gfc_expr *); +void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_transpose (gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); @@ -343,17 +371,27 @@ void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); /* Intrinsic subroutine resolution. */ +void gfc_resolve_chdir_sub (gfc_code *); void gfc_resolve_cpu_time (gfc_code *); void gfc_resolve_exit (gfc_code *); void gfc_resolve_flush (gfc_code *); void gfc_resolve_fstat_sub (gfc_code *); +void gfc_resolve_gerror (gfc_code *); void gfc_resolve_getarg (gfc_code *); void gfc_resolve_getcwd_sub (gfc_code *); +void gfc_resolve_getlog (gfc_code *); void gfc_resolve_get_command (gfc_code *); void gfc_resolve_get_command_argument (gfc_code *); void gfc_resolve_get_environment_variable (gfc_code *); +void gfc_resolve_hostnm_sub (gfc_code *); +void gfc_resolve_kill_sub (gfc_code *); void gfc_resolve_mvbits (gfc_code *); +void gfc_resolve_perror (gfc_code *); void gfc_resolve_random_number (gfc_code *); +void gfc_resolve_rename_sub (gfc_code *); +void gfc_resolve_link_sub (gfc_code *); +void gfc_resolve_symlnk_sub (gfc_code *); +void gfc_resolve_sleep_sub (gfc_code *); void gfc_resolve_stat_sub (gfc_code *); void gfc_resolve_system_clock (gfc_code *); void gfc_resolve_system_sub (gfc_code *); @@ -365,6 +403,6 @@ void gfc_resolve_unlink_sub (gfc_code *); #define MAX_INTRINSIC_ARGS 5 -extern char *gfc_current_intrinsic, - *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +extern const char *gfc_current_intrinsic; +extern const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; extern locus *gfc_current_intrinsic_where; diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi new file mode 100644 index 00000000000..2f13838f1d6 --- /dev/null +++ b/gcc/fortran/intrinsic.texi @@ -0,0 +1,1904 @@ +@ignore +Copyright (C) 2005 +Free Software Foundation, Inc. +This is part of the GFORTRAN manual. +For copying conditions, see the file gfortran.texi. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with the +Invariant Sections being ``GNU General Public License'' and ``Funding +Free Software'', the Front-Cover texts being (a) (see below), and with +the Back-Cover Texts being (b) (see below). A copy of the license is +included in the gfdl(7) man page. + + +Some basic guidelines for editing this document: + + (1) The intrinsic procedures are to be listed in alphabetical order. + (2) The generic name is to be use. + (3) The specific names are included in the function index and in a + table at the end of the node (See ABS entry). + (4) Try to maintain the same style for each entry. + + +@end ignore + +@node Intrinsic Procedures +@chapter Intrinsic Procedures +@cindex Intrinsic Procedures + +This portion of the document is incomplete and undergoing massive expansion +and editing. All contributions and corrections are strongly encouraged. + +@menu +* Introduction: Introduction +* @code{ABORT}: ABORT, Abort the program +* @code{ABS}: ABS, Absolute value +* @code{ACHAR}: ACHAR, Character in @acronym{ASCII} collating sequence +* @code{ACOS}: ACOS, Arccosine function +* @code{ADJUSTL}: ADJUSTL, Left adjust a string +* @code{ADJUSTR}: ADJUSTR, Right adjust a string +* @code{AIMAG}: AIMAG, Imaginary part of complex number +* @code{AINT}: AINT, Truncate to a whole number +* @code{ALL}: ALL, Determine if all values are true +* @code{ALLOCATED}: ALLOCATED, Status of allocatable entity +* @code{ANINT}: ANINT, Nearest whole number +* @code{ANY}: ANY, Determine if any values are true +* @code{ASIN}: ASIN, Arcsine function +* @code{ATAN}: ATAN, Arctangent function +* @code{BESJ0}: BESJ0, Bessel function of the first kind of order 0 +* @code{BESJ1}: BESJ1, Bessel function of the first kind of order 1 +* @code{BESJN}: BESJN, Bessel function of the first kind +* @code{BESY0}: BESY0, Bessel function of the second kind of order 0 +* @code{BESY1}: BESY1, Bessel function of the second kind of order 1 +* @code{BESYN}: BESYN, Bessel function of the second kind +* @code{COS}: COS, Cosine function +* @code{COSH}: COSH, Hyperbolic cosine function +* @code{ERF}: ERF, Error function +* @code{ERFC}: ERFC, Complementary error function +* @code{EXP}: EXP, Cosine function +* @code{LOG}: LOG, Logarithm function +* @code{LOG10}: LOG10, Base 10 logarithm function +* @code{SQRT}: SQRT, Square-root function +* @code{SIN}: SIN, Sine function +* @code{SINH}: SINH, Hyperbolic sine function +* @code{TAN}: TAN, Tangent function +* @code{TANH}: TANH, Hyperbolic tangent function +@end menu + +@node Introduction +@section Introduction to intrinsic procedures + +Gfortran provides a rich set of intrinsic procedures that includes all +the intrinsic procedures required by the Fortran 95 standard, a set of +intrinsic procedures for backwards compatibility with Gnu Fortran 77 +(i.e., @command{g77}), and a small selection of intrinsic procedures +from the Fortran 2003 standard. Any description here, which conflicts with a +description in either the Fortran 95 standard or the Fortran 2003 standard, +is unintentional and the standard(s) should be considered authoritative. + +The enumeration of the @code{KIND} type parameter is processor defined in +the Fortran 95 standard. Gfortran defines the default integer type and +default real type by @code{INTEGER(KIND=4)} and @code{REAL(KIND=4)}, +respectively. The standard mandates that both data types shall have +another kind, which have more precision. On typical target architectures +supports by @command{gfortran}, this kind type parameter is @code{KIND=8}. +Hence, @code{REAL(KIND=8)} and @code{DOUBLE PRECISION} are equivalent. +In the description of generic intrinsic procedures, the kind type parameter +will be specified by @code{KIND=*}, and in the description of specific +names for an intrinsic procedure the kind type parameter will be explicitly +given (e.g., @code{REAL(KIND=4)} or @code{REAL(KIND=8)}). Finally, for +brevity the optional @code{KIND=} syntax will be omitted. + +Many of the intrinsics procedures take one or more optional arguments. +This document follows the convention used in the Fortran 95 standard, +and denotes such arguments by square brackets. + +@command{Gfortran} offers the @option{-std=f95} and @option{-std=gnu} options, +which can be used to restrict the set of intrinsic procedures to a +given standard. By default, @command{gfortran} sets the @option{-std=gnu} +option, and so all intrinsic procedures describe here are accepted. There +is one caveat. For a select group of intrinsic procedures, @command{g77} +implemented both a function and a subroutine. Both classes +have been implemented in @command{gfortran} for backwards compatibility +with @command{g77}. It is noted here that these functions and subroutines +cannot be intermixed in a given subprogram. In the descriptions that follow, +the applicable option(s) is noted. + + + +@node ABORT +@section @code{ABORT} --- Abort the program +@findex @code{ABORT} +@cindex abort + +@table @asis +@item @emph{Description}: +@code{ABORT} causes immediate termination of the program. On operating +systems that support a core dump, @code{ABORT} will produce a core dump, +which is suitable for debugging purposes. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +non-elemental subroutine + +@item @emph{Syntax}: +@code{CALL ABORT} + +@item @emph{Return value}: +Does not return. + +@item @emph{Example}: +@smallexample +program test_abort + integer :: i = 1, j = 2 + if (i /= j) call abort +end program test_abort +@end smallexample +@end table + + + +@node ABS +@section @code{ABS} --- Absolute value +@findex @code{ABS} intrinsic +@findex @code{CABS} intrinsic +@findex @code{DABS} intrinsic +@findex @code{IABS} intrinsic +@findex @code{ZABS} intrinsic +@findex @code{CDABS} intrinsic +@cindex absolute value + +@table @asis +@item @emph{Description}: +@code{ABS(X)} computes the absolute value of @code{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ABS(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type of the argument shall be an @code{INTEGER(*)}, +@code{REAL(*)}, or @code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and +kind as the argument except the return value is @code{REAL(*)} for a +@code{COMPLEX(*)} argument. + +@item @emph{Example}: +@smallexample +program test_abs + integer :: i = -1 + real :: x = -1.e0 + complex :: z = (-1.e0,0.e0) + i = abs(i) + x = abs(x) + x = abs(z) +end program test_abs +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{CABS(Z)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab f95, gnu +@item @code{DABS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{IABS(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab f95, gnu +@item @code{ZABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab gnu +@item @code{CDABS(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab gnu +@end multitable +@end table + + + +@node ACHAR +@section @code{ACHAR} --- Character in @acronym{ASCII} collating sequence +@findex @code{ACHAR} intrinsic +@cindex @acronym{ASCII} collating sequence + +@table @asis +@item @emph{Description}: +@code{ACHAR(I)} returns the character located at position @code{I} +in the @acronym{ASCII} collating sequence. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{C = ACHAR(I)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{I} @tab The type shall be an @code{INTEGER(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{CHARACTER} with a length of one. The +kind type parameter is the same as @code{KIND('A')}. + +@item @emph{Example}: +@smallexample +program test_achar + character c + c = achar(32) +end program test_achar +@end smallexample +@end table + + + +@node ACOS +@section @code{ACOS} --- Arccosine function +@findex @code{ACOS} intrinsic +@findex @code{DACOS} intrinsic +@cindex arccosine + +@table @asis +@item @emph{Description}: +@code{ACOS(X)} computes the arccosine of its @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ACOS(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}, and a magnitude that is +less than one. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it lies in the +range @math{ 0 \leq \arccos (x) \leq \pi}. The kind type +parameter is the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_acos + real(8) :: x = 0.866_8 + x = achar(x) +end program test_acos +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + + +@node ADJUSTL +@section @code{ADJUSTL} --- Left adjust a string +@findex @code{ADJUSTL} intrinsic +@cindex adjust string + +@table @asis +@item @emph{Description}: +@code{ADJUSTL(STR)} will left adjust a string by removing leading spaces. +Spaces are inserted at the end of the string as needed. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{STR = ADJUSTL(STR)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{STR} @tab The type shall be @code{CHARACTER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{CHARACTER} where leading spaces +are removed and the same number of spaces are inserted on the end +of @var{STR}. + +@item @emph{Example}: +@smallexample +program test_adjustl + character(len=20) :: str = ' gfortran' + str = adjustl(str) + print *, str +end program test_adjustl +@end smallexample +@end table + + +@node ADJUSTR +@section @code{ADJUSTR} --- Right adjust a string +@findex @code{ADJUSTR} intrinsic +@cindex adjust string + +@table @asis +@item @emph{Description}: +@code{ADJUSTR(STR)} will right adjust a string by removing trailing spaces. +Spaces are inserted at the start of the string as needed. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{STR = ADJUSTR(STR)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{STR} @tab The type shall be @code{CHARACTER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{CHARACTER} where trailing spaces +are removed and the same number of spaces are inserted at the start +of @var{STR}. + +@item @emph{Example}: +@smallexample +program test_adjustr + character(len=20) :: str = 'gfortran' + str = adjustr(str) + print *, str +end program test_adjustr +@end smallexample +@end table + + +@node AIMAG +@section @code{AIMAG} --- Imaginary part of complex number +@findex @code{AIMAG} intrinsic +@findex @code{DIMAG} intrinsic +@cindex Imaginary part + +@table @asis +@item @emph{Description}: +@code{AIMAG(Z)} yields the imaginary part of complex argument @code{Z}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = AIMAG(Z)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{Z} @tab The type of the argument shall be @code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type real with the +kind type parameter of the argument. + +@item @emph{Example}: +@smallexample +program test_aimag + complex(4) z4 + complex(8) z8 + z4 = cmplx(1.e0_4, 0.e0_4) + z8 = cmplx(0.e0_8, 1.e0_8) + print *, aimag(z4), dimag(z8) +end program test_aimag +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node AINT +@section @code{AINT} --- Imaginary part of complex number +@findex @code{AINT} intrinsic +@findex @code{DINT} intrinsic +@cindex whole number + +@table @asis +@item @emph{Description}: +@code{AINT(X [, KIND])} truncates its argument to a whole number. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = AINT(X)} @* +@code{X = AINT(X, KIND)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type of the argument shall be @code{REAL(*)}. +@item @var{KIND} @tab (Optional) @var{KIND} shall be a scalar integer +initialization expression. +@end multitable + +@item @emph{Return value}: +The return value is of type real with the kind type parameter of the +argument if the optional @var{KIND} is absence; otherwise, the kind +type parameter will be given by @var{KIND}. If the magnitude of +@var{X} is less than one, then @code{AINT(X)} returns zero. If the +magnitude is equal to or greater than one, then it returns the largest +whole number that does not exceed its magnitude. The sign is the same +as the sign of @var{X}. + +@item @emph{Example}: +@smallexample +program test_aint + real(4) x4 + real(8) x8 + x4 = 1.234E0_4 + x8 = 4.321_8 + print *, aint(x4), dint(x8) + x8 = aint(x4,8) +end program test_aint +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node ALL +@section @code{ALL} --- All values in @var{MASK} along @var{DIM} are true + @findex @code{ALL} intrinsic +@cindex true values + +@table @asis +@item @emph{Description}: +@code{ALL(MASK [, DIM])} determines if all the values are true in @var{MASK} +in the array along dimension @var{DIM}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +transformational function + +@item @emph{Syntax}: +@code{L = ALL(MASK)} @* +@code{L = ALL(MASK, DIM)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL(*)} and +it shall not be scalar. +@item @var{DIM} @tab (Optional) @var{DIM} shall be a scalar integer +with a value that lies between one and the rank of @var{MASK}. +@end multitable + +@item @emph{Return value}: +@code{ALL(MASK)} returns a scalar value of type @code{LOGICAL(*)} where +the kind type parameter is the same as the kind type parameter of +@var{MASK}. If @var{DIM} is present, then @code{ALL(MASK, DIM)} returns +an array with the rank of @var{MASK} minus 1. The shape is determined from +the shape of @var{MASK} where the @var{DIM} dimension is elided. + +@table @asis +@item (A) +@code{ALL(MASK)} is true if all elements of @var{MASK} are true. +It also is true if @var{MASK} has zero size; otherwise, it is false. +@item (B) +If the rank of @var{MASK} is one, then @code{ALL(MASK,DIM)} is equivalent +to @code{ALL(MASK)}. If the rank is greater than one, then @code{ALL(MASK,DIM)} +is determined by applying @code{ALL} to the array sections. +@end table + +@item @emph{Example}: +@smallexample +program test_all + logical l + l = all((/.true., .true., .true./)) + print *, l + call section + contains + subroutine section + integer a(2,3), b(2,3) + a = 1 + b = 1 + b(2,2) = 2 + print *, all(a .eq. b, 1) + print *, all(a .eq. b, 2) + end subroutine section +end program test_all +@end smallexample +@end table + + +@node ALLOCATED +@section @code{ALLOCATED} --- Status of an allocatable entity +@findex @code{ALLOCATED} intrinsic +@cindex allocation status + +@table @asis +@item @emph{Description}: +@code{ALLOCATED(X)} checks the status of wether @var{X} is allocated. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +inquiry function + +@item @emph{Syntax}: +@code{L = ALLOCATED(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The argument shall be an @code{ALLOCATABLE} array. +@end multitable + +@item @emph{Return value}: +The return value is a scalar @code{LOGICAL} with the default logical +kind type parameter. If @var{X} is allocated, @code{ALLOCATED(X)} +is @code{.TRUE.}; otherwise, it returns the @code{.TRUE.} + +@item @emph{Example}: +@smallexample +program test_allocated + integer :: i = 4 + real(4), allocatable :: x(:) + if (allocated(x) .eqv. .false.) allocate(x(i) +end program test_allocated +@end smallexample +@end table + + +@node ANINT +@section @code{ANINT} --- Imaginary part of complex number +@findex @code{ANINT} intrinsic +@findex @code{DNINT} intrinsic +@cindex whole number + +@table @asis +@item @emph{Description}: +@code{ANINT(X [, KIND])} rounds its argument to the nearest whole number. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ANINT(X)} @* +@code{X = ANINT(X, KIND)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type of the argument shall be @code{REAL(*)}. +@item @var{KIND} @tab (Optional) @var{KIND} shall be a scalar integer +initialization expression. +@end multitable + +@item @emph{Return value}: +The return value is of type real with the kind type parameter of the +argument if the optional @var{KIND} is absence; otherwise, the kind +type parameter will be given by @var{KIND}. If @var{X} is greater than +zero, then @code{ANINT(X)} returns @code{AINT(X+0.5)}. If @var{X} is +less than or equal to zero, then return @code{AINT(X-0.5)}. + +@item @emph{Example}: +@smallexample +program test_anint + real(4) x4 + real(8) x8 + x4 = 1.234E0_4 + x8 = 4.321_8 + print *, anint(x4), dnint(x8) + x8 = anint(x4,8) +end program test_anint +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DNINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node ANY +@section @code{ANY} --- Any value in @var{MASK} along @var{DIM} is true + @findex @code{ANY} intrinsic +@cindex true values + +@table @asis +@item @emph{Description}: +@code{ANY(MASK [, DIM])} determines if any of the values is true in @var{MASK} +in the array along dimension @var{DIM}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +transformational function + +@item @emph{Syntax}: +@code{L = ANY(MASK)} @* +@code{L = ANY(MASK, DIM)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{MASK} @tab The type of the argument shall be @code{LOGICAL(*)} and +it shall not be scalar. +@item @var{DIM} @tab (Optional) @var{DIM} shall be a scalar integer +with a value that lies between one and the rank of @var{MASK}. +@end multitable + +@item @emph{Return value}: +@code{ANY(MASK)} returns a scalar value of type @code{LOGICAL(*)} where +the kind type parameter is the same as the kind type parameter of +@var{MASK}. If @var{DIM} is present, then @code{ANY(MASK, DIM)} returns +an array with the rank of @var{MASK} minus 1. The shape is determined from +the shape of @var{MASK} where the @var{DIM} dimension is elided. + +@table @asis +@item (A) +@code{ANY(MASK)} is true if any element of @var{MASK} is true; +otherwise, it is false. It also is false if @var{MASK} has zero size. +@item (B) +If the rank of @var{MASK} is one, then @code{ANY(MASK,DIM)} is equivalent +to @code{ANY(MASK)}. If the rank is greater than one, then @code{ANY(MASK,DIM)} +is determined by applying @code{ANY} to the array sections. +@end table + +@item @emph{Example}: +@smallexample +program test_any + logical l + l = any((/.true., .true., .true./)) + print *, l + call section + contains + subroutine section + integer a(2,3), b(2,3) + a = 1 + b = 1 + b(2,2) = 2 + print *, any(a .eq. b, 1) + print *, any(a .eq. b, 2) + end subroutine section +end program test_any +@end smallexample +@end table + + +@node ASIN +@section @code{ASIN} --- Arcsine function +@findex @code{ASIN} intrinsic +@findex @code{DASIN} intrinsic +@cindex arcsine + +@table @asis +@item @emph{Description}: +@code{ASIN(X)} computes the arcsine of its @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ASIN(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}, and a magnitude that is +less than one. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it lies in the +range @math{ \pi / 2 \leq \arccos (x) \leq \pi / 2}. The kind type +parameter is the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_asin + real(8) :: x = 0.866_8 + x = asin(x) +end program test_asin +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DASIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node ATAN +@section @code{ATAN} --- Arctangent function +@findex @code{ATAN} intrinsic +@findex @code{DATAN} intrinsic +@cindex arctangent + +@table @asis +@item @emph{Description}: +@code{ATAN(X)} computes the arctangent of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ATAN(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it lies in the +range @math{ - \pi / 2 \leq \arcsin (x) \leq \pi / 2}. + +@item @emph{Example}: +@smallexample +program test_atan + real(8) :: x = 2.866_8 + x = atan(x) +end program test_atan +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DATAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + + +@node BESJ0 +@section @code{BESJ0} --- Bessel function of the first kind of order 0 +@findex @code{BESJ0} intrinsic +@findex @code{DBESJ0} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESJ0(X)} computes the Bessel function of the first kind of order 0 +of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = BESJ0(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it lies in the +range @math{ - 0.4027... \leq Bessel (0,x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_besj0 + real(8) :: x = 0.0_8 + x = besj0(x) +end program test_besj0 +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESJ0(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node BESJ1 +@section @code{BESJ1} --- Bessel function of the first kind of order 1 +@findex @code{BESJ1} intrinsic +@findex @code{DBESJ1} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESJ1(X)} computes the Bessel function of the first kind of order 1 +of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = BESJ1(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it lies in the +range @math{ - 0.5818... \leq Bessel (0,x) \leq 0.5818 }. + +@item @emph{Example}: +@smallexample +program test_besj1 + real(8) :: x = 1.0_8 + x = besj1(x) +end program test_besj1 +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESJ1(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node BESJN +@section @code{BESJN} --- Bessel function of the first kind +@findex @code{BESJN} intrinsic +@findex @code{DBESJN} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESJN(N, X)} computes the Bessel function of the first kind of order +@var{N} of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{Y = BESJN(N, X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{N} @tab The type shall be an @code{INTEGER(*)}. +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. + +@item @emph{Example}: +@smallexample +program test_besjn + real(8) :: x = 1.0_8 + x = besjn(5,x) +end program test_besjn +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESJN(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node BESY0 +@section @code{BESY0} --- Bessel function of the second kind of order 0 +@findex @code{BESY0} intrinsic +@findex @code{DBESY0} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESY0(X)} computes the Bessel function of the second kind of order 0 +of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = BESY0(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. + +@item @emph{Example}: +@smallexample +program test_besy0 + real(8) :: x = 0.0_8 + x = besy0(x) +end program test_besy0 +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESY0(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node BESY1 +@section @code{BESY1} --- Bessel function of the second kind of order 1 +@findex @code{BESY1} intrinsic +@findex @code{DBESY1} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESY1(X)} computes the Bessel function of the second kind of order 1 +of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = BESY1(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. + +@item @emph{Example}: +@smallexample +program test_besy1 + real(8) :: x = 1.0_8 + x = besy1(x) +end program test_besy1 +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESY1(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node BESYN +@section @code{BESYN} --- Bessel function of the second kind +@findex @code{BESYN} intrinsic +@findex @code{DBESYN} intrinsic +@cindex Bessel + +@table @asis +@item @emph{Description}: +@code{BESYN(N, X)} computes the Bessel function of the second kind of order +@var{N} of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{Y = BESYN(N, X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{N} @tab The type shall be an @code{INTEGER(*)}. +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. + +@item @emph{Example}: +@smallexample +program test_besyn + real(8) :: x = 1.0_8 + x = besyn(5,x) +end program test_besyn +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DBESYN(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + +@node COS +@section @code{COS} --- Cosine function +@findex @code{COS} intrinsic +@findex @code{DCOS} intrinsic +@findex @code{ZCOS} intrinsic +@findex @code{CDCOS} intrinsic +@cindex cosine + +@table @asis +@item @emph{Description}: +@code{COS(X)} computes the cosine of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = COS(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value has same type and kind than @var{X}. + +@item @emph{Example}: +@smallexample +program test_cos + real :: x = 0.0 + x = cos(x) +end program test_cos +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@end multitable +@end table + + +@node COSH +@section @code{COSH} --- Hyperbolic cosine function +@findex @code{COSH} intrinsic +@findex @code{DCOSH} intrinsic +@cindex hyperbolic cosine + +@table @asis +@item @emph{Description}: +@code{COSH(X)} computes the hyperbolic cosine of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = COSH(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it is positive +(@math{ \cosh (x) \geq 0 }. + +@item @emph{Example}: +@smallexample +program test_cosh + real(8) :: x = 1.0_8 + x = cosh(x) +end program test_cosh +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DCOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node ERF +@section @code{ERF} --- Error function +@findex @code{ERF} intrinsic +@cindex error + +@table @asis +@item @emph{Description}: +@code{ERF(X)} computes the error function of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ERF(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it is positive +(@math{ - 1 \leq erf (x) \leq 1 }. + +@item @emph{Example}: +@smallexample +program test_erf + real(8) :: x = 0.17_8 + x = erf(x) +end program test_erf +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DERF(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node ERFC +@section @code{ERFC} --- Error function +@findex @code{ERFC} intrinsic +@cindex error + +@table @asis +@item @emph{Description}: +@code{ERFC(X)} computes the complementary error function of @var{X}. + +@item @emph{Option}: +gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = ERFC(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and it is positive +(@math{ 0 \leq erfc (x) \leq 2 }. + +@item @emph{Example}: +@smallexample +program test_erfc + real(8) :: x = 0.17_8 + x = erfc(x) +end program test_erfc +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DERFC(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab gnu +@end multitable +@end table + + + +@node EXP +@section @code{EXP} --- Exponential function +@findex @code{EXP} intrinsic +@findex @code{DEXP} intrinsic +@findex @code{ZEXP} intrinsic +@findex @code{CDEXP} intrinsic +@cindex exponential + +@table @asis +@item @emph{Description}: +@code{EXP(X)} computes the base @math{e} exponential of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = EXP(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value has same type and kind than @var{X}. + +@item @emph{Example}: +@smallexample +program test_exp + real :: x = 1.0 + x = exp(x) +end program test_exp +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DEXP(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CEXP(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZEXP(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDEXP(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@end multitable +@end table + + +@node LOG +@section @code{LOG} --- Logarithm function +@findex @code{LOG} intrinsic +@findex @code{ALOG} intrinsic +@findex @code{DLOG} intrinsic +@findex @code{CLOG} intrinsic +@findex @code{ZLOG} intrinsic +@findex @code{CDLOG} intrinsic +@cindex logarithm + +@table @asis +@item @emph{Description}: +@code{LOG(X)} computes the logarithm of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = LOG(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The kind type parameter is the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_log + real(8) :: x = 1.0_8 + complex :: z = (1.0, 2.0) + x = log(x) + z = log(z) +end program test_log +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{ALOG(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab f95, gnu +@item @code{DLOG(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CLOG(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZLOG(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDLOG(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@end multitable +@end table + + + +@node LOG10 +@section @code{LOG10} --- Base 10 logarithm function +@findex @code{LOG10} intrinsic +@findex @code{ALOG10} intrinsic +@findex @code{DLOG10} intrinsic +@cindex logarithm + +@table @asis +@item @emph{Description}: +@code{LOG10(X)} computes the base 10 logarithm of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = LOG10(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The kind type parameter is the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_log10 + real(8) :: x = 10.0_8 + x = log10(x) +end program test_log10 +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{ALOG10(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab f95, gnu +@item @code{DLOG10(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + + +@node SIN +@section @code{SIN} --- Sine function +@findex @code{SIN} intrinsic +@findex @code{DSIN} intrinsic +@findex @code{ZSIN} intrinsic +@findex @code{CDSIN} intrinsic +@cindex sine + +@table @asis +@item @emph{Description}: +@code{SIN(X)} computes the sine of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = SIN(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value has same type and king than @var{X}. + +@item @emph{Example}: +@smallexample +program test_sin + real :: x = 0.0 + x = sin(x) +end program test_sin +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DSIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CSIN(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@end multitable +@end table + + + + +@node SINH +@section @code{SINH} --- Hyperbolic sine function +@findex @code{SINH} intrinsic +@findex @code{DSINH} intrinsic +@cindex hyperbolic sine + +@table @asis +@item @emph{Description}: +@code{SINH(X)} computes the hyperbolic sine of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = SINH(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. + +@item @emph{Example}: +@smallexample +program test_sinh + real(8) :: x = - 1.0_8 + x = sinh(x) +end program test_sinh +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DSINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + + +@node SQRT +@section @code{SQRT} --- Square-root function +@findex @code{SQRT} intrinsic +@findex @code{DSQRT} intrinsic +@findex @code{CSQRT} intrinsic +@findex @code{ZSQRT} intrinsic +@findex @code{CDSQRT} intrinsic +@cindex square-root + +@table @asis +@item @emph{Description}: +@code{SQRT(X)} computes the square root of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = SQRT(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)} or +@code{COMPLEX(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} or @code{COMPLEX(*)}. +The kind type parameter is the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_sqrt + real(8) :: x = 2.0_8 + complex :: z = (1.0, 2.0) + x = sqrt(x) + z = sqrt(z) +end program test_sqrt +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DSQRT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CSQRT(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZSQRT(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDSQRT(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@end multitable +@end table + + + +@node TAN +@section @code{TAN} --- Tangent function +@findex @code{TAN} intrinsic +@findex @code{DTAN} intrinsic +@cindex tangent + +@table @asis +@item @emph{Description}: +@code{TAN(X)} computes the tangent of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = TAN(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)}. The kind type parameter is +the same as @var{X}. + +@item @emph{Example}: +@smallexample +program test_tan + real(8) :: x = 0.165_8 + x = tan(x) +end program test_tan +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + +@node TANH +@section @code{TANH} --- Hyperbolic tangent function +@findex @code{TANH} intrinsic +@findex @code{DTANH} intrinsic +@cindex hyperbolic tangent + +@table @asis +@item @emph{Description}: +@code{TANH(X)} computes the hyperbolic tangent of @var{X}. + +@item @emph{Option}: +f95, gnu + +@item @emph{Type}: +elemental function + +@item @emph{Syntax}: +@code{X = TANH(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{X} @tab The type shall be an @code{REAL(*)}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{REAL(*)} and lies in the range +@math{ - 1 \leq tanh(x) \leq 1 }. + +@item @emph{Example}: +@smallexample +program test_tanh + real(8) :: x = 2.1_8 + x = tanh(x) +end program test_tanh +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .24 .24 .24 .24 +@item Name @tab Argument @tab Return type @tab Option +@item @code{DTANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@end multitable +@end table + + + +@comment gen associated +@comment +@comment gen atan2 +@comment datan2 +@comment +@comment gen bit_size +@comment +@comment gen btest +@comment +@comment gen ceiling +@comment +@comment gen char +@comment +@comment gen cmplx +@comment +@comment gen command_argument_count +@comment +@comment gen conjg +@comment dconjg +@comment +@comment gen count +@comment +@comment sub cpu_time +@comment +@comment gen cshift +@comment +@comment sub date_and_time +@comment +@comment gen dble +@comment dfloat +@comment +@comment gen dcmplx +@comment +@comment gen digits +@comment +@comment gen dim +@comment idim +@comment ddim +@comment +@comment gen dot_product +@comment +@comment gen dprod +@comment +@comment gen dreal +@comment +@comment sub dtime +@comment +@comment gen eoshift +@comment +@comment gen epsilon +@comment +@comment gen etime +@comment sub etime +@comment +@comment sub exit +@comment +@comment gen exponent +@comment +@comment gen floor +@comment +@comment sub flush +@comment +@comment gen fnum +@comment +@comment gen fraction +@comment +@comment gen fstat +@comment sub fstat +@comment +@comment sub getarg +@comment +@comment gen getcwd +@comment sub getcwd +@comment +@comment sub getenv +@comment +@comment gen getgid +@comment +@comment gen getpid +@comment +@comment gen getuid +@comment +@comment sub get_command +@comment +@comment sub get_command_argument +@comment +@comment sub get_environment_variable +@comment +@comment gen huge +@comment +@comment gen iachar +@comment +@comment gen iand +@comment +@comment gen iargc +@comment +@comment gen ibclr +@comment +@comment gen ibits +@comment +@comment gen ibset +@comment +@comment gen ichar +@comment +@comment gen ieor +@comment +@comment gen index +@comment +@comment gen int +@comment ifix +@comment idint +@comment +@comment gen ior +@comment +@comment gen irand +@comment +@comment gen ishft +@comment +@comment gen ishftc +@comment +@comment gen kind +@comment +@comment gen lbound +@comment +@comment gen len +@comment +@comment gen len_trim +@comment +@comment gen lge +@comment +@comment gen lgt +@comment +@comment gen lle +@comment +@comment gen llt +@comment +@comment gen logical +@comment +@comment gen matmul +@comment +@comment gen max +@comment max0 +@comment amax0 +@comment amax1 +@comment max1 +@comment dmax1 +@comment +@comment gen maxexponent +@comment +@comment gen maxloc +@comment +@comment gen maxval +@comment +@comment gen merge +@comment +@comment gen min +@comment min0 +@comment amin0 +@comment amin1 +@comment min1 +@comment dmin1 +@comment +@comment gen minexponent +@comment +@comment gen minloc +@comment +@comment gen minval +@comment +@comment gen mod +@comment amod +@comment dmod +@comment +@comment gen modulo +@comment +@comment sub mvbits +@comment +@comment gen nearest +@comment +@comment gen nint +@comment idnint +@comment +@comment gen not +@comment +@comment gen null +@comment +@comment gen pack +@comment +@comment gen precision +@comment +@comment gen present +@comment +@comment gen product +@comment +@comment gen radix +@comment +@comment gen rand +@comment ran +@comment +@comment sub random_number +@comment +@comment sub random_seed +@comment +@comment gen range +@comment +@comment gen real +@comment float +@comment sngl +@comment +@comment gen repeat +@comment +@comment gen reshape +@comment +@comment gen rrspacing +@comment +@comment gen scale +@comment +@comment gen scan +@comment +@comment gen second +@comment sub second +@comment +@comment gen selected_int_kind +@comment +@comment gen selected_real_kind +@comment +@comment gen set_exponent +@comment +@comment gen shape +@comment +@comment gen sign +@comment isign +@comment dsign +@comment +@comment gen size +@comment +@comment gen spacing +@comment +@comment gen spread +@comment +@comment sub srand +@comment +@comment gen stat +@comment sub stat +@comment +@comment gen sum +@comment +@comment gen system +@comment sub system +@comment +@comment sub system_clock +@comment +@comment gen tiny +@comment +@comment gen transfer +@comment +@comment gen transpose +@comment +@comment gen trim +@comment +@comment gen ubound +@comment +@comment gen umask +@comment sub umask +@comment +@comment gen unlink +@comment sub unlink +@comment +@comment gen unpack +@comment +@comment gen verify + diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 0d2f94d4f49..7ffd7af5515 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -119,7 +119,7 @@ by type. Explanations are in the following sections. -fdollar-ok -fimplicit-none -fmax-identifier-length @gol -std=@var{std} -ffixed-line-length-@var{n} -ffixed-line-length-none @gol --i8 -r8 -d8} +-fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 } @item Warning Options @xref{Warning Options,,Options to Request or Suppress Warnings}. @@ -183,6 +183,23 @@ Specify the layout used by the the source file. The free form layout was introduced in Fortran 90. Fixed form was traditionally used in older Fortran programs. +@cindex option, -fdefault-double-8 +@cindex -fdefault-double-8, option +@item -fdefault-double-8 +Set the "DOUBLE PRECISION" type to an 8 byte wide. + +@cindex option, -fdefault-integer-8 +@cindex -fdefault-integer-8, option +@item -fdefault-integer-8 +Set the default integer and logical types to an 8 byte wide type. +Do nothing if this is already the default. + +@cindex option, -fdefault-real-8 +@cindex -fdefault-real-8, option +@item -fdefault-real-8 +Set the default real type to an 8 byte wide type. +Do nothing if this is already the default. + @cindex -fdollar-ok option @cindex options, -fdollar-ok @item -fdollar-ok @@ -231,24 +248,7 @@ Specify that no implicit typing is allowed, unless overridden by explicit @cindex option, -std=@var{std} @item -std=@var{std} Conform to the specified standard. Allowed values for @var{std} are -@samp{gnu}, @samp{f95} and @samp{f90}. - -@cindex option, -i8 -@cindex -i8, option -@cindex option, -r8 -@cindex -r8, option -@cindex option, -d8 -@cindex -d8, option -@item -i8 -@item -r8 -@item -d8 -The @option{-i8} and @option{-r8} options set the default @code{INTEGER} -and @code{REAL} kinds to @code{KIND=8}. The @option{-d8} option is -equivalent to specifying both @option{-i8} and @option{-r8}. - -When @option{-r8} is specified, the @code{DOUBLE PRECISION} kind is set -to @code{KIND=16} if the target supports a 16 byte floating point format. -If no such format exists, the @code{DOUBLE PRECISION} kind is unchanged. +@samp{gnu} and @samp{f95}. @end table @@ -371,8 +371,8 @@ This currently produces a warning under the following circumstances: @itemize @bullet @item -An INTEGER SELECT construct has a CASE the can never be matched as it's -lower value that is greater than its upper value. +An INTEGER SELECT construct has a CASE that can never be matched as its +lower value is greater than its upper value. @item A LOGICAL SELECT construct has three CASE statements. diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 8230fa99cd0..12650f90f24 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -981,6 +981,14 @@ resolve_tag (const io_tag * tag, gfc_expr * e) &e->where); return FAILURE; } + /* Check assigned label. */ + if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER + && e->symtree->n.sym->attr.assign != 1) + { + gfc_error ("Variable '%s' has not been assigned a format label at %L", + e->symtree->n.sym->name, &e->where); + return FAILURE; + } } else { @@ -1526,9 +1534,6 @@ match_dt_format (gfc_dt * dt) gfc_free_expr (e); goto conflict; } - if (e->ts.type == BT_INTEGER && e->rank == 0) - e->symtree->n.sym->attr.assign = 1; - dt->format_expr = e; return MATCH_YES; } diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index a4ab2251761..746b97df444 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -253,6 +253,31 @@ gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind) void +gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind); +} + + +void +gfc_resolve_chdir_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind) { f->ts.type = BT_COMPLEX; @@ -383,9 +408,9 @@ gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b) { temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = INTRINSIC_NONE; - temp.op1 = a; - temp.op2 = b; + temp.value.op.operator = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; gfc_type_convert_binary (&temp); f->ts = temp.ts; } @@ -533,6 +558,14 @@ gfc_resolve_getuid (gfc_expr * f) } void +gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("hostnm")); +} + +void gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j) { /* If the kind of i and j are different, then g77 cross-promoted the @@ -596,6 +629,15 @@ gfc_resolve_idnint (gfc_expr * f, gfc_expr * a) void +gfc_resolve_ierrno (gfc_expr * f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind); +} + + +void gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j) { /* If the kind of i and j are different, then g77 cross-promoted the @@ -670,6 +712,17 @@ gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift, void +gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p, + ATTRIBUTE_UNUSED gfc_expr * s) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + + f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind); +} + + +void gfc_resolve_lbound (gfc_expr * f, gfc_expr * array, gfc_expr * dim) { @@ -708,6 +761,16 @@ gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string) void +gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED, + gfc_expr * p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind); +} + + +void gfc_resolve_log (gfc_expr * f, gfc_expr * x) { f->ts = x->ts; @@ -753,9 +816,9 @@ gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b) { temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = INTRINSIC_NONE; - temp.op1 = a; - temp.op2 = b; + temp.value.op.operator = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; gfc_type_convert_binary (&temp); f->ts = temp.ts; } @@ -1019,6 +1082,16 @@ gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind) void +gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED, + gfc_expr * p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind); +} + + +void gfc_resolve_repeat (gfc_expr * f, gfc_expr * string, gfc_expr * ncopies ATTRIBUTE_UNUSED) { @@ -1275,6 +1348,16 @@ gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim, } +void +gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED, + gfc_expr * p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind); +} + + /* Resolve the g77 compatibility function SYSTEM. */ void @@ -1305,6 +1388,24 @@ gfc_resolve_tanh (gfc_expr * f, gfc_expr * x) void +gfc_resolve_time (gfc_expr * f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX("time_func")); +} + + +void +gfc_resolve_time8 (gfc_expr * f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name = gfc_get_string (PREFIX("time8_func")); +} + + +void gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED, gfc_expr * mold, gfc_expr * size) { @@ -1490,6 +1591,70 @@ gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED) } +void +gfc_resolve_rename_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("rename_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_kill_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("kill_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_link_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("link_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_symlnk_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + /* G77 compatibility subroutines etime() and dtime(). */ void @@ -1514,6 +1679,22 @@ gfc_resolve_second_sub (gfc_code * c) } +void +gfc_resolve_sleep_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->expr != NULL) + kind = c->ext.actual->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + /* G77 compatibility function srand(). */ void @@ -1665,6 +1846,43 @@ gfc_resolve_flush (gfc_code * c) c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } + +void +gfc_resolve_gerror (gfc_code * c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror")); +} + + +void +gfc_resolve_getlog (gfc_code * c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog")); +} + + +void +gfc_resolve_hostnm_sub (gfc_code * c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_perror (gfc_code * c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub")); +} + /* Resolve the STAT and FSTAT intrinsic subroutines. */ void diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 976a2b436d2..bde1d753b07 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -69,9 +69,17 @@ Wunused-labels F95 Warn when a label is unused -d8 -F95 RejectNegative -Set the default real and integer kinds to double precision +fdefault-double-8 +F95 +Set the default double precision kind to an 8 byte wide type + +fdefault-integer-8 +F95 +Set the default integer kind to an 8 byte wide type + +fdefault-real-8 +F95 +Set the default real kind to an 8 byte wide type fdollar-ok F95 @@ -133,18 +141,10 @@ frepack-arrays F95 Copy array sections into a contiguous block on procedure entry -i8 -F95 -Set the default integer kind to double precision - qkind= F95 RejectNegative Joined UInteger -qkind=<n> Set the kind for a real with the 'q' exponent to 'n' -r8 -F95 -Set the default real kind to double precision - std=f95 F95 Conform to the ISO Fortran 95 standard. diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2a364478530..f433db52c5d 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1526,7 +1526,6 @@ gfc_match_goto (void) == FAILURE) return MATCH_ERROR; - expr->symtree->n.sym->attr.assign = 1; new_st.op = EXEC_GOTO; new_st.expr = expr; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 1d46e85960c..2351f9b92bf 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -108,6 +108,8 @@ match gfc_match_derived_decl (void); match gfc_match_implicit_none (void); match gfc_match_implicit (void); +void gfc_set_constant_character_len (int, gfc_expr *); + /* Matchers for attribute declarations */ match gfc_match_allocatable (void); match gfc_match_dimension (void); diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c index bde8d603dea..04fd31f3609 100644 --- a/gcc/fortran/matchexp.c +++ b/gcc/fortran/matchexp.c @@ -179,11 +179,11 @@ build_node (gfc_intrinsic_op operator, locus * where, new = gfc_get_expr (); new->expr_type = EXPR_OP; - new->operator = operator; + new->value.op.operator = operator; new->where = *where; - new->op1 = op1; - new->op2 = op2; + new->value.op.op1 = op1; + new->value.op.op2 = op2; return new; } @@ -214,7 +214,7 @@ match_level_1 (gfc_expr ** result) else { f = build_node (INTRINSIC_USER, &where, e, NULL); - f->uop = uop; + f->value.op.uop = uop; *result = f; } @@ -873,7 +873,7 @@ gfc_match_expr (gfc_expr ** result) } all = build_node (INTRINSIC_USER, &where, all, e); - all->uop = uop; + all->value.op.uop = uop; } *result = all; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 12d52c419a9..4b69b738db1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -655,7 +655,8 @@ compare_true_names (void * _t1, void * _t2) t1 = (true_name *) _t1; t2 = (true_name *) _t2; - c = strcmp (t1->sym->module, t2->sym->module); + c = ((t1->sym->module > t2->sym->module) + - (t1->sym->module < t2->sym->module)); if (c != 0) return c; @@ -673,8 +674,11 @@ find_true_name (const char *name, const char *module) gfc_symbol sym; int c; - strcpy (sym.name, name); - strcpy (sym.module, module); + sym.name = gfc_get_string (name); + if (module != NULL) + sym.module = gfc_get_string (module); + else + sym.module = NULL; t.sym = &sym; p = true_name_root; @@ -1341,8 +1345,33 @@ mio_allocated_string (const char *s) } -/* Read or write a string that is in static memory or inside of some - already-allocated structure. */ +/* Read or write a string that is in static memory. */ + +static void +mio_pool_string (const char **stringp) +{ + /* TODO: one could write the string only once, and refer to it via a + fixup pointer. */ + + /* As a special case we have to deal with a NULL string. This + happens for the 'module' member of 'gfc_symbol's that are not in a + module. We read / write these as the empty string. */ + if (iomode == IO_OUTPUT) + { + const char *p = *stringp == NULL ? "" : *stringp; + write_atom (ATOM_STRING, p); + } + else + { + require_atom (ATOM_STRING); + *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string); + gfc_free (atom_string); + } +} + + +/* Read or write a string that is inside of some already-allocated + structure. */ static void mio_internal_string (char *string) @@ -1802,7 +1831,7 @@ mio_component_ref (gfc_component ** cp, gfc_symbol * sym) p->type = P_COMPONENT; if (iomode == IO_OUTPUT) - mio_internal_string ((*cp)->name); + mio_pool_string (&(*cp)->name); else { mio_internal_string (name); @@ -1851,7 +1880,7 @@ mio_component (gfc_component * c) if (p->type == P_UNKNOWN) p->type = P_COMPONENT; - mio_internal_string (c->name); + mio_pool_string (&c->name); mio_typespec (&c->ts); mio_array_spec (&c->as); @@ -1907,7 +1936,7 @@ mio_actual_arg (gfc_actual_arglist * a) { mio_lparen (); - mio_internal_string (a->name); + mio_pool_string (&a->name); mio_expr (&a->expr); mio_rparen (); } @@ -2404,14 +2433,15 @@ mio_expr (gfc_expr ** ep) switch (e->expr_type) { case EXPR_OP: - e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics); + e->value.op.operator + = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics); - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: case INTRINSIC_NOT: - mio_expr (&e->op1); + mio_expr (&e->value.op.op1); break; case INTRINSIC_PLUS: @@ -2430,8 +2460,8 @@ mio_expr (gfc_expr ** ep) case INTRINSIC_GE: case INTRINSIC_LT: case INTRINSIC_LE: - mio_expr (&e->op1); - mio_expr (&e->op2); + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); break; default: @@ -2598,14 +2628,14 @@ mio_interface (gfc_interface ** ip) /* Save/restore a named operator interface. */ static void -mio_symbol_interface (char *name, char *module, +mio_symbol_interface (const char **name, const char **module, gfc_interface ** ip) { mio_lparen (); - mio_internal_string (name); - mio_internal_string (module); + mio_pool_string (name); + mio_pool_string (module); mio_interface_rest (ip); } @@ -2627,7 +2657,7 @@ mio_namespace_ref (gfc_namespace ** nsp) ns = (gfc_namespace *)p->u.pointer; if (ns == NULL) { - ns = gfc_get_namespace (NULL); + ns = gfc_get_namespace (NULL, 0); associate_integer_pointer (p, ns); } else @@ -2878,12 +2908,12 @@ load_needed (pointer_info * p) the namespaces that hold the formal parameters of module procedures. */ - ns = gfc_get_namespace (NULL); + ns = gfc_get_namespace (NULL, 0); associate_integer_pointer (q, ns); } sym = gfc_new_symbol (p->u.rsym.true_name, ns); - strcpy (sym->module, p->u.rsym.module); + sym->module = gfc_get_string (p->u.rsym.module); associate_integer_pointer (p, sym); } @@ -3036,7 +3066,7 @@ read_module (void) sym = info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); - strcpy (sym->module, info->u.rsym.module); + sym->module = gfc_get_string (info->u.rsym.module); } st->n.sym = sym; @@ -3169,7 +3199,7 @@ write_common (gfc_symtree *st) write_common(st->right); mio_lparen(); - mio_internal_string(st->name); + mio_pool_string(&st->name); p = st->n.common; mio_symbol_ref(&p->head); @@ -3189,9 +3219,9 @@ write_symbol (int n, gfc_symbol * sym) gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); mio_integer (&n); - mio_internal_string (sym->name); + mio_pool_string (&sym->name); - mio_internal_string (sym->module); + mio_pool_string (&sym->module); mio_pointer_ref (&sym->ns); mio_symbol (sym); @@ -3216,8 +3246,8 @@ write_symbol0 (gfc_symtree * st) write_symbol0 (st->right); sym = st->n.sym; - if (sym->module[0] == '\0') - strcpy (sym->module, module_name); + if (sym->module == NULL) + sym->module = gfc_get_string (module_name); if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic && !sym->attr.subroutine && !sym->attr.function) @@ -3264,8 +3294,8 @@ write_symbol1 (pointer_info * p) /* FIXME: This shouldn't be necessary, but it works around deficiencies in the module loader or/and symbol handling. */ - if (p->u.wsym.sym->module[0] == '\0' && p->u.wsym.sym->attr.dummy) - strcpy (p->u.wsym.sym->module, module_name); + if (p->u.wsym.sym->module == NULL && p->u.wsym.sym->attr.dummy) + p->u.wsym.sym->module = gfc_get_string (module_name); p->u.wsym.state = WRITTEN; write_symbol (p->integer, p->u.wsym.sym); @@ -3280,12 +3310,13 @@ static void write_operator (gfc_user_op * uop) { static char nullstring[] = ""; + const char *p = nullstring; if (uop->operator == NULL || !gfc_check_access (uop->access, uop->ns->default_access)) return; - mio_symbol_interface (uop->name, nullstring, &uop->operator); + mio_symbol_interface (&uop->name, &p, &uop->operator); } @@ -3299,7 +3330,7 @@ write_generic (gfc_symbol * sym) || !gfc_check_access (sym->attr.access, sym->ns->default_access)) return; - mio_symbol_interface (sym->name, sym->module, &sym->generic); + mio_symbol_interface (&sym->name, &sym->module, &sym->generic); } @@ -3322,7 +3353,7 @@ write_symtree (gfc_symtree * st) if (p == NULL) gfc_internal_error ("write_symtree(): Symbol not written"); - mio_internal_string (st->name); + mio_pool_string (&st->name); mio_integer (&st->ambiguous); mio_integer (&p->integer); } diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 35964003785..21fb0a83c52 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -57,6 +57,9 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, gfc_option.warn_surprising = 0; gfc_option.warn_unused_labels = 0; + gfc_option.flag_default_double = 0; + gfc_option.flag_default_integer = 0; + gfc_option.flag_default_real = 0; gfc_option.flag_dollar_ok = 0; gfc_option.flag_underscoring = 1; gfc_option.flag_second_underscore = 1; @@ -68,9 +71,6 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, gfc_option.flag_repack_arrays = 0; gfc_option.q_kind = gfc_default_double_kind; - gfc_option.i8 = 0; - gfc_option.r8 = 0; - gfc_option.d8 = 0; flag_argument_noalias = 2; flag_errno_math = 0; @@ -285,16 +285,16 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_option.q_kind = value; break; - case OPT_i8: - gfc_option.i8 = value; + case OPT_fdefault_integer_8: + gfc_option.flag_default_integer = value; break; - case OPT_r8: - gfc_option.r8 = value; + case OPT_fdefault_real_8: + gfc_option.flag_default_real = value; break; - case OPT_d8: - gfc_option.d8 = value; + case OPT_fdefault_double_8: + gfc_option.flag_default_double = value; break; case OPT_I: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index dac40775d05..a3f0ac19539 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1405,7 +1405,7 @@ parse_interface (void) current_state = COMP_NONE; loop: - gfc_current_ns = gfc_get_namespace (current_interface.ns); + gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); st = next_statement (); switch (st) @@ -2170,7 +2170,7 @@ parse_contained (int module) do { - gfc_current_ns = gfc_get_namespace (parent_ns); + gfc_current_ns = gfc_get_namespace (parent_ns, 1); gfc_current_ns->sibling = parent_ns->contained; parent_ns->contained = gfc_current_ns; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index f122779b136..992bc5f0af7 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -300,17 +300,15 @@ match_boz_constant (gfc_expr ** result) match_digits (0, radix, buffer); gfc_next_char (); /* Eat delimiter. */ - kind = get_kind (); - if (kind == -1) - return MATCH_ERROR; - if (kind == -2) - kind = gfc_default_integer_kind; - else if (pedantic - && (gfc_notify_std (GFC_STD_GNU, "Extension: Kind parameter " - "suffix to boz literal constant at %C.") - == FAILURE)) - return MATCH_ERROR; + /* 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 + variable shall be of type integer. The boz-literal-constant is treated + as if it were an int-literal-constant with a kind-param that specifies + the representation method with the largest decimal exponent range + supported by the processor." */ + + kind = gfc_max_integer_kind; e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus); if (gfc_range_check (e) != ARITH_OK) @@ -1076,7 +1074,17 @@ match_complex_constant (gfc_expr ** result) m = gfc_match_char (')'); if (m == MATCH_NO) + { + /* 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 () == '=') + { + m = MATCH_ERROR; + goto cleanup; + } + else goto syntax; + } if (m == MATCH_ERROR) goto cleanup; @@ -1273,7 +1281,7 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) if (name[0] != '\0') { for (a = base; a; a = a->next) - if (strcmp (a->name, name) == 0) + if (a->name != NULL && strcmp (a->name, name) == 0) { gfc_error ("Keyword '%s' at %C has already appeared in the current " @@ -1282,7 +1290,7 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) } } - strcpy (actual->name, name); + actual->name = gfc_get_string (name); return MATCH_YES; cleanup: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index dd69a983406..16db94342d1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -481,7 +481,7 @@ was_declared (gfc_symbol * sym) if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) return 1; - if (a.allocatable || a.dimension || a.external || a.intrinsic + if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN) return 1; @@ -884,8 +884,8 @@ set_type: } -/* Figure out if if a function reference is pure or not. Also sets the name - of the function for a potential error message. Returns nonzero if the +/* Figure out if a function reference is pure or not. Also set the name + of the function for a potential error message. Return nonzero if the function is PURE, zero if not. */ static int @@ -1249,6 +1249,36 @@ resolve_call (gfc_code * c) return t; } +/* Compare the shapes of two arrays that have non-NULL shapes. If both + op1->shape and op2->shape are non-NULL return SUCCESS if their shapes + match. If both op1->shape and op2->shape are non-NULL return FAILURE + if their shapes do not match. If either op1->shape or op2->shape is + NULL, return SUCCESS. */ + +static try +compare_shapes (gfc_expr * op1, gfc_expr * op2) +{ + try t; + int i; + + t = SUCCESS; + + if (op1->shape != NULL && op2->shape != NULL) + { + for (i = 0; i < op1->rank; i++) + { + if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) + { + gfc_error ("Shapes for operands at %L and %L are not conformable", + &op1->where, &op2->where); + t = FAILURE; + break; + } + } + } + + return t; +} /* Resolve an operator expression node. This can involve replacing the operation with a user defined function call. */ @@ -1262,10 +1292,10 @@ resolve_operator (gfc_expr * e) /* Resolve all subnodes-- give them types. */ - switch (e->operator) + switch (e->value.op.operator) { default: - if (gfc_resolve_expr (e->op2) == FAILURE) + if (gfc_resolve_expr (e->value.op.op2) == FAILURE) return FAILURE; /* Fall through... */ @@ -1273,17 +1303,17 @@ resolve_operator (gfc_expr * e) case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - if (gfc_resolve_expr (e->op1) == FAILURE) + if (gfc_resolve_expr (e->value.op.op1) == FAILURE) return FAILURE; break; } /* Typecheck the new node. */ - op1 = e->op1; - op2 = e->op2; + op1 = e->value.op.op1; + op2 = e->value.op.op2; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: @@ -1296,7 +1326,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s", - gfc_op2string (e->operator), gfc_typename (&e->ts)); + gfc_op2string (e->value.op.operator), gfc_typename (&e->ts)); goto bad_op; case INTRINSIC_PLUS: @@ -1312,7 +1342,7 @@ resolve_operator (gfc_expr * e) sprintf (msg, "Operands of binary numeric operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1345,7 +1375,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1393,7 +1423,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1401,10 +1431,10 @@ resolve_operator (gfc_expr * e) case INTRINSIC_USER: if (op2 == NULL) sprintf (msg, "Operand of user operator '%s' at %%L is %s", - e->uop->name, gfc_typename (&op1->ts)); + e->value.op.uop->name, gfc_typename (&op1->ts)); else sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s", - e->uop->name, gfc_typename (&op1->ts), + e->value.op.uop->name, gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1417,7 +1447,7 @@ resolve_operator (gfc_expr * e) t = SUCCESS; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_PLUS: case INTRINSIC_MINUS: @@ -1460,10 +1490,14 @@ resolve_operator (gfc_expr * e) if (op1->rank == op2->rank) { e->rank = op1->rank; - if (e->shape == NULL) + { + t = compare_shapes(op1, op2); + if (t == FAILURE) + e->shape = NULL; + else e->shape = gfc_copy_shape (op1->shape, op1->rank); - + } } else { @@ -1499,10 +1533,12 @@ resolve_operator (gfc_expr * e) return t; bad_op: + if (gfc_extend_expr (e) == SUCCESS) return SUCCESS; gfc_error (msg, &e->where); + return FAILURE; } @@ -1665,19 +1701,26 @@ gfc_resolve_index (gfc_expr * index, int check_scalar) if (gfc_resolve_expr (index) == FAILURE) return FAILURE; - if (index->ts.type != BT_INTEGER) + if (check_scalar && index->rank != 0) { - gfc_error ("Array index at %L must be of INTEGER type", &index->where); + gfc_error ("Array index at %L must be scalar", &index->where); return FAILURE; } - if (check_scalar && index->rank != 0) + if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) { - gfc_error ("Array index at %L must be scalar", &index->where); + gfc_error ("Array index at %L must be of INTEGER type", + &index->where); return FAILURE; } - if (index->ts.kind != gfc_index_integer_kind) + if (index->ts.type == BT_REAL) + if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L", + &index->where) == FAILURE) + return FAILURE; + + if (index->ts.kind != gfc_index_integer_kind + || index->ts.type != BT_INTEGER) { ts.type = BT_INTEGER; ts.kind = gfc_index_integer_kind; @@ -3327,23 +3370,27 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) gfc_error ("Unsupported statement while finding forall index in " "expression"); break; - default: + + case EXPR_OP: + /* Find the FORALL index in the first operand. */ + if (expr->value.op.op1) + { + if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS) + return SUCCESS; + } + + /* Find the FORALL index in the second operand. */ + if (expr->value.op.op2) + { + if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS) + return SUCCESS; + } break; - } - /* Find the FORALL index in the first operand. */ - if (expr->op1) - { - if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS) - return SUCCESS; + default: + break; } - /* Find the FORALL index in the second operand. */ - if (expr->op2) - { - if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS) - return SUCCESS; - } return FAILURE; } @@ -3648,10 +3695,17 @@ resolve_code (gfc_code * code, gfc_namespace * ns) break; case EXEC_GOTO: - if (code->expr != NULL && code->expr->ts.type != BT_INTEGER) - gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER " + if (code->expr != NULL) + { + if (code->expr->ts.type != BT_INTEGER) + gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER " "variable", &code->expr->where); - else + else if (code->expr->symtree->n.sym->attr.assign != 1) + gfc_error ("Variable '%s' has not been assigned a target label " + "at %L", code->expr->symtree->n.sym->name, + &code->expr->where); + } + else resolve_branch (code->label, code); break; @@ -4709,10 +4763,11 @@ gfc_resolve (gfc_namespace * ns) if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE) continue; - if (cl->length->ts.type != BT_INTEGER) - gfc_error - ("Character length specification at %L must be of type INTEGER", - &cl->length->where); + if (gfc_simplify_expr (cl->length, 0) == FAILURE) + continue; + + if (gfc_specification_expr (cl->length) == FAILURE) + continue; } gfc_traverse_ns (ns, resolve_values); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 423f3336d8b..d6e988b9176 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -592,7 +592,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) gfc_expr *ceil, *result; int kind; - kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; @@ -1017,7 +1017,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k) mpfr_t floor; int kind; - kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); if (kind == -1) gfc_internal_error ("gfc_simplify_floor(): Bad kind"); @@ -1473,7 +1473,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k) gfc_expr *rpart, *rtrunc, *result; int kind; - kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; @@ -1766,16 +1766,18 @@ gfc_simplify_kind (gfc_expr * e) static gfc_expr * -gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) +simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) { gfc_ref *ref; gfc_array_spec *as; - int i; + gfc_expr *e; + int d; if (array->expr_type != EXPR_VARIABLE) return NULL; if (dim == NULL) + /* TODO: Simplify constant multi-dimensional bounds. */ return NULL; if (dim->expr_type != EXPR_CONSTANT) @@ -1783,29 +1785,66 @@ gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) /* Follow any component references. */ as = array->symtree->n.sym->as; - ref = array->ref; - while (ref->next != NULL) + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + goto done; + + case AR_SECTION: + case AR_UNKNOWN: + return NULL; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + gcc_unreachable (); + + done: + if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > as->rank + || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper)) { - if (ref->type == REF_COMPONENT) - as = ref->u.c.sym->as; - ref = ref->next; + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; } - if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL) + e = upper ? as->upper[d-1] : as->lower[d-1]; + + if (e->expr_type != EXPR_CONSTANT) return NULL; - - i = mpz_get_si (dim->value.integer); - if (upper) - return gfc_copy_expr (as->upper[i-1]); - else - return gfc_copy_expr (as->lower[i-1]); + + return gfc_copy_expr (e); } gfc_expr * gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim) { - return gfc_simplify_bound (array, dim, 0); + return simplify_bound (array, dim, 0); } @@ -3578,7 +3617,7 @@ gfc_simplify_trim (gfc_expr * e) gfc_expr * gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim) { - return gfc_simplify_bound (array, dim, 1); + return simplify_bound (array, dim, 1); } diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index b6515376e38..f4b32006ad1 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -1,5 +1,5 @@ /* Build executable statement trees. - Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c9205d58459..26e3f003442 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -179,8 +179,7 @@ gfc_merge_new_implicit (gfc_typespec * ts) } -/* Given a symbol, return a pointer to the typespec for it's default - type. */ +/* Given a symbol, return a pointer to the typespec for its default type. */ gfc_typespec * gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns) @@ -214,9 +213,12 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) if (ts->type == BT_UNKNOWN) { - if (error_flag) - gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name, - &sym->declared_at); + if (error_flag && !sym->attr.untyped) + { + gfc_error ("Symbol '%s' at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + sym->attr.untyped = 1; /* Ensure we only give an error once. */ + } return FAILURE; } @@ -367,6 +369,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) { case PROC_ST_FUNCTION: conf2 (in_common); + conf2 (dummy); break; case PROC_MODULE: @@ -483,9 +486,9 @@ check_used (symbol_attribute * attr, const char * name, locus * where) /* Used to prevent changing the attributes of a symbol after it has been - used. This check is only done from dummy variable as only these can be + used. This check is only done for dummy variables as only these can be used in specification expressions. Applying this to all symbols causes - error when we reach the body of a contained function. */ + an error when we reach the body of a contained function. */ static int check_done (symbol_attribute * attr, locus * where) @@ -684,7 +687,7 @@ gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where) if (check_used (attr, name, where)) return FAILURE; - /* Duplicate dummy arguments are allow due to ENTRY statements. */ + /* Duplicate dummy arguments are allowed due to ENTRY statements. */ attr->dummy = 1; return check_conflict (attr, name, where); } @@ -836,7 +839,7 @@ gfc_add_generic (symbol_attribute * attr, const char *name, locus * where) } -/* Flavors are special because some flavors are not what fortran +/* Flavors are special because some flavors are not what Fortran considers attributes and can be reaffirmed multiple times. */ try @@ -1102,7 +1105,7 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; /* The subroutines that set these bits also cause flavors to be set, - and that has already happened in the original, so don't let to + and that has already happened in the original, so don't let it happen again. */ if (src->external) dest->external = 1; @@ -1147,7 +1150,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen tail = p; } - /* Allocate new component */ + /* Allocate a new component. */ p = gfc_get_component (); if (tail == NULL) @@ -1155,7 +1158,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen else tail->next = p; - strcpy (p->name, name); + p->name = gfc_get_string (name); p->loc = gfc_current_locus; *component = p; @@ -1194,7 +1197,7 @@ switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) have to have a derived type in a parent unit. We find the node in the other namespace and point the symtree node in this namespace to that node. Further reference to this name point to the correct - node. If we can't find the node in a parent namespace, then have + node. If we can't find the node in a parent namespace, then we have an error. This subroutine takes a pointer to a symbol node and returns a @@ -1521,7 +1524,7 @@ done: the internal subprograms must be read before we can start generating code for the host. - Given the tricky nature of the fortran grammar, we must be able to + Given the tricky nature of the Fortran grammar, we must be able to undo changes made to a symbol table if the current interpretation of a statement is found to be incorrect. Whenever a symbol is looked up, we make a copy of it and link to it. All of these @@ -1532,10 +1535,11 @@ done: this case, that symbol has been used as a host associated variable at some previous time. */ -/* Allocate a new namespace structure. */ +/* Allocate a new namespace structure. Copies the implicit types from + PARENT if PARENT_TYPES is set. */ gfc_namespace * -gfc_get_namespace (gfc_namespace * parent) +gfc_get_namespace (gfc_namespace * parent, int parent_types) { gfc_namespace *ns; gfc_typespec *ts; @@ -1557,7 +1561,7 @@ gfc_get_namespace (gfc_namespace * parent) ns->set_flag[i - 'a'] = 0; ts = &ns->default_type[i - 'a']; - if (ns->parent != NULL) + if (parent_types && ns->parent != NULL) { /* Copy parent settings */ *ts = ns->parent->default_type[i - 'a']; @@ -1610,7 +1614,7 @@ gfc_new_symtree (gfc_symtree ** root, const char *name) gfc_symtree *st; st = gfc_getmem (sizeof (gfc_symtree)); - strcpy (st->name, name); + st->name = gfc_get_string (name); gfc_insert_bbt (root, st, compare_symtree); return st; @@ -1626,7 +1630,7 @@ delete_symtree (gfc_symtree ** root, const char *name) st0 = gfc_find_symtree (*root, name); - strcpy (st.name, name); + st.name = gfc_get_string (name); gfc_delete_bbt (root, &st, compare_symtree); gfc_free (st0); @@ -1671,7 +1675,7 @@ gfc_get_uop (const char *name) st = gfc_new_symtree (&gfc_current_ns->uop_root, name); uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op)); - strcpy (uop->name, name); + uop->name = gfc_get_string (name); uop->access = ACCESS_UNKNOWN; uop->ns = gfc_current_ns; @@ -1740,7 +1744,7 @@ gfc_new_symbol (const char *name, gfc_namespace * ns) if (strlen (name) > GFC_MAX_SYMBOL_LEN) gfc_internal_error ("new_symbol(): Symbol name too long"); - strcpy (p->name, name); + p->name = gfc_get_string (name); return p; } @@ -1751,7 +1755,7 @@ static void ambiguous_symbol (const char *name, gfc_symtree * st) { - if (st->n.sym->module[0]) + if (st->n.sym->module) gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " "from module '%s'", name, st->n.sym->name, st->n.sym->module); else @@ -2244,7 +2248,7 @@ void gfc_symbol_init_2 (void) { - gfc_current_ns = gfc_get_namespace (NULL); + gfc_current_ns = gfc_get_namespace (NULL, 0); } @@ -2359,7 +2363,7 @@ gfc_symbol_state(void) { /* Search a tree for the global symbol. */ gfc_gsymbol * -gfc_find_gsymbol (gfc_gsymbol *symbol, char *name) +gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) { gfc_gsymbol *s; @@ -2396,7 +2400,7 @@ gsym_compare (void * _s1, void * _s2) /* Get a global symbol, creating it if it doesn't exist. */ gfc_gsymbol * -gfc_get_gsymbol (char *name) +gfc_get_gsymbol (const char *name) { gfc_gsymbol *s; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e281619741d..bd77eb46850 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -99,43 +99,6 @@ static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); static gfc_ss gfc_ss_terminator_var; gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; -unsigned HOST_WIDE_INT gfc_stack_space_left; - - -/* Returns true if a variable of specified size should go on the stack. */ - -int -gfc_can_put_var_on_stack (tree size) -{ - unsigned HOST_WIDE_INT low; - - if (!INTEGER_CST_P (size)) - return 0; - - if (gfc_option.flag_max_stack_var_size < 0) - return 1; - - if (TREE_INT_CST_HIGH (size) != 0) - return 0; - - low = TREE_INT_CST_LOW (size); - if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size) - return 0; - -/* TODO: Set a per-function stack size limit. */ -#if 0 - /* We should be a bit more clever with array temps. */ - if (gfc_option.flag_max_function_vars_size >= 0) - { - if (low > gfc_stack_space_left) - return 0; - - gfc_stack_space_left -= low; - } -#endif - - return 1; -} static tree gfc_array_dataptr_type (tree desc) @@ -1271,7 +1234,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) /* Also the data pointer. */ tmp = gfc_conv_array_data (se.expr); /* If this is a variable or address of a variable we use it directly. - Otherwise we must evaluate it now to to avoid break dependency + Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ if (!(DECL_P (tmp) @@ -3071,7 +3034,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) gcc_assert (!sym->attr.use_assoc); gcc_assert (!TREE_STATIC (decl)); - gcc_assert (!sym->module[0]); + gcc_assert (!sym->module); if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) @@ -4194,18 +4157,18 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) gfc_ss *head2; gfc_ss *newss; - head = gfc_walk_subexpr (ss, expr->op1); - if (expr->op2 == NULL) + head = gfc_walk_subexpr (ss, expr->value.op.op1); + if (expr->value.op.op2 == NULL) head2 = head; else - head2 = gfc_walk_subexpr (head, expr->op2); + head2 = gfc_walk_subexpr (head, expr->value.op.op2); /* All operands are scalar. Pass back and let the caller deal with it. */ if (head2 == ss) return head2; /* All operands require scalarization. */ - if (head != ss && (expr->op2 == NULL || head2 != head)) + if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) return head2; /* One of the operands needs scalarization, the other is scalar. @@ -4223,7 +4186,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) gcc_assert (head); newss->next = ss; head->next = newss; - newss->expr = expr->op1; + newss->expr = expr->value.op.op1; } else /* head2 == head */ { @@ -4231,7 +4194,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) /* Second operand is scalar. */ newss->next = head2; head2 = newss; - newss->expr = expr->op2; + newss->expr = expr->value.op.op2; } return head2; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index b4407693909..faaaf5ade4b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -95,11 +95,6 @@ tree gfc_conv_array_stride (tree, int); tree gfc_conv_array_lbound (tree, int); tree gfc_conv_array_ubound (tree, int); -/* The remaining space available for stack variables. */ -extern unsigned HOST_WIDE_INT gfc_stack_space_left; -/* Returns true if a variable of specified size should go on the stack. */ -int gfc_can_put_var_on_stack (tree); - /* Build expressions for accessing components of an array descriptor. */ tree gfc_conv_descriptor_data (tree); tree gfc_conv_descriptor_offset (tree); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 6a6e1395f10..42e67123328 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -242,6 +242,27 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) size_binop (PLUS_EXPR, DECL_FIELD_OFFSET (field), DECL_SIZE_UNIT (field))); + /* If this field is assigned to a label, we create another two variables. + One will hold the address of taget label or format label. The other will + hold the length of format label string. */ + if (h->sym->attr.assign) + { + tree len; + tree addr; + + gfc_allocate_lang_decl (field); + GFC_DECL_ASSIGN (field) = 1; + len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); + addr = gfc_create_var_np (pvoid_type_node, h->sym->name); + TREE_STATIC (len) = 1; + TREE_STATIC (addr) = 1; + DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2); + gfc_set_decl_location (len, &h->sym->declared_at); + gfc_set_decl_location (addr, &h->sym->declared_at); + GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); + GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); + } + h->field = field; } @@ -252,6 +273,8 @@ static tree build_equiv_decl (tree union_type, bool is_init) { tree decl; + char name[15]; + static int serial = 0; if (is_init) { @@ -260,10 +283,13 @@ build_equiv_decl (tree union_type, bool is_init) return decl; } - decl = build_decl (VAR_DECL, NULL, union_type); + snprintf (name, sizeof (name), "equiv.%d", serial++); + decl = build_decl (VAR_DECL, get_identifier (name), union_type); DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; - DECL_COMMON (decl) = 1; + if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))) + TREE_STATIC (decl) = 1; TREE_ADDRESSABLE (decl) = 1; TREE_USED (decl) = 1; @@ -288,7 +314,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) /* Create a namespace to store symbols for common blocks. */ if (gfc_common_ns == NULL) - gfc_common_ns = gfc_get_namespace (NULL); + gfc_common_ns = gfc_get_namespace (NULL, 0); gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; @@ -353,7 +379,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) backend declarations for all of the elements. */ static void -create_common (gfc_common_head *com, segment_info * head) +create_common (gfc_common_head *com, segment_info * head, bool saw_equiv) { segment_info *s, *next_s; tree union_type; @@ -362,8 +388,16 @@ create_common (gfc_common_head *com, segment_info * head) tree decl; bool is_init = false; - /* Declare the variables inside the common block. */ - union_type = make_node (UNION_TYPE); + /* Declare the variables inside the common block. + If the current common block contains any equivalence object, then + make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the + alias analyzer work well when there is no address overlapping for + common variables in the current common block. */ + if (saw_equiv) + union_type = make_node (UNION_TYPE); + else + union_type = make_node (RECORD_TYPE); + rli = start_record_layout (union_type); field_link = &TYPE_FIELDS (union_type); @@ -429,7 +463,7 @@ create_common (gfc_common_head *com, segment_info * head) for (s = head; s; s = next_s) { s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field), - decl, s->field, NULL_TREE); + decl, s->field, NULL_TREE); next_s = s->next; gfc_free (s); @@ -677,7 +711,7 @@ find_equivalence (segment_info *n) segment list multiple times to include indirect equivalences. */ static void -add_equivalences (void) +add_equivalences (bool *saw_equiv) { segment_info *f; bool more; @@ -692,6 +726,8 @@ add_equivalences (void) { f->sym->equiv_built = 1; more = find_equivalence (f); + if (more) + *saw_equiv = true; } } } @@ -762,10 +798,12 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list) HOST_WIDE_INT current_offset; unsigned HOST_WIDE_INT align; unsigned HOST_WIDE_INT max_align; + bool saw_equiv; common_segment = NULL; current_offset = 0; max_align = 1; + saw_equiv = false; /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) @@ -795,7 +833,7 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list) /* Add all objects directly or indirectly equivalenced with this symbol. */ - add_equivalences (); + add_equivalences (&saw_equiv); if (current_segment->offset < 0) gfc_error ("The equivalence set for '%s' cause an invalid " @@ -839,7 +877,7 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list) common->name, &common->where, common_segment->offset); } - create_common (common, common_segment); + create_common (common, common_segment, saw_equiv); } @@ -852,6 +890,7 @@ finish_equivalences (gfc_namespace *ns) gfc_symbol *sym; HOST_WIDE_INT offset; unsigned HOST_WIDE_INT align; + bool dummy; for (z = ns->equiv; z; z = z->next) for (y = z->eq; y; y = y->eq) @@ -862,7 +901,7 @@ finish_equivalences (gfc_namespace *ns) current_segment = get_segment_info (sym, 0); /* All objects directly or indirectly equivalenced with this symbol. */ - add_equivalences (); + add_equivalences (&dummy); /* Align the block. */ offset = align_segment (&align); @@ -873,7 +912,7 @@ finish_equivalences (gfc_namespace *ns) apply_segment_offset (current_segment, offset); /* Create the decl. */ - create_common (NULL, current_segment); + create_common (NULL, current_segment, true); break; } } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 6567695ad29..08dd72af697 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -272,7 +272,7 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) { char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - if (sym->module[0] == 0) + if (sym->module == NULL) return gfc_sym_identifier (sym); else { @@ -290,8 +290,8 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) int has_underscore; char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL - || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY)) + if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL + || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY)) { if (strcmp (sym->name, "MAIN__") == 0 || sym->attr.proc == PROC_INTRINSIC) @@ -317,6 +317,32 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) } +/* Returns true if a variable of specified size should go on the stack. */ + +int +gfc_can_put_var_on_stack (tree size) +{ + unsigned HOST_WIDE_INT low; + + if (!INTEGER_CST_P (size)) + return 0; + + if (gfc_option.flag_max_stack_var_size < 0) + return 1; + + if (TREE_INT_CST_HIGH (size) != 0) + return 0; + + low = TREE_INT_CST_LOW (size); + if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size) + return 0; + +/* TODO: Set a per-function stack size limit. */ + + return 1; +} + + /* Finish processing of a declaration and install its initial value. */ static void @@ -404,7 +430,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) DECL_EXTERNAL (decl) = 1; TREE_PUBLIC (decl) = 1; } - else if (sym->module[0] && !sym->attr.result && !sym->attr.dummy) + else if (sym->module && !sym->attr.result && !sym->attr.dummy) { /* TODO: Don't set sym->module for result or dummy variables. */ gcc_assert (current_function_decl == NULL_TREE); @@ -533,7 +559,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) /* For some dummy arguments we don't use the actual argument directly. - Instead we create a local decl and use that. This allows us to preform + Instead we create a local decl and use that. This allows us to perform initialization, and construct full type information. */ static tree @@ -766,7 +792,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Symbols from modules should have their assembler names mangled. This is done here rather than in gfc_finish_var_decl because it is different for string length variables. */ - if (sym->module[0]) + if (sym->module) SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym)); if (sym->attr.dimension) @@ -808,7 +834,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) { char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2]; - if (sym->module[0]) + if (sym->module) { /* Also prefix the mangled name for symbols from modules. */ strcpy (&name[1], sym->name); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 494faa44135..b79d0743dec 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -414,7 +414,7 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) gcc_assert (expr->ts.type != BT_CHARACTER); /* Initialize the operand. */ gfc_init_se (&operand, se); - gfc_conv_expr_val (&operand, expr->op1); + gfc_conv_expr_val (&operand, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &operand.pre); type = gfc_typenode_for_spec (&expr->ts); @@ -607,25 +607,25 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) tree tmp; gfc_init_se (&lse, se); - gfc_conv_expr_val (&lse, expr->op1); + gfc_conv_expr_val (&lse, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &lse.pre); gfc_init_se (&rse, se); - gfc_conv_expr_val (&rse, expr->op2); + gfc_conv_expr_val (&rse, expr->value.op.op2); gfc_add_block_to_block (&se->pre, &rse.pre); - if (expr->op2->ts.type == BT_INTEGER - && expr->op2->expr_type == EXPR_CONSTANT) + if (expr->value.op.op2->ts.type == BT_INTEGER + && expr->value.op.op2->expr_type == EXPR_CONSTANT) if (gfc_conv_cst_int_power (se, lse.expr, rse.expr)) return; gfc_int4_type_node = gfc_get_int_type (4); - kind = expr->op1->ts.kind; - switch (expr->op2->ts.type) + kind = expr->value.op.op1->ts.kind; + switch (expr->value.op.op2->ts.type) { case BT_INTEGER: - ikind = expr->op2->ts.kind; + ikind = expr->value.op.op2->ts.kind; switch (ikind) { case 1: @@ -648,7 +648,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) { case 1: case 2: - if (expr->op1->ts.type == BT_INTEGER) + if (expr->value.op.op1->ts.type == BT_INTEGER) lse.expr = convert (gfc_int4_type_node, lse.expr); else gcc_unreachable (); @@ -666,7 +666,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gcc_unreachable (); } - switch (expr->op1->ts.type) + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: fndecl = gfor_fndecl_math_powi[kind][ikind].integer; @@ -780,14 +780,14 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) tree args; tree tmp; - gcc_assert (expr->op1->ts.type == BT_CHARACTER - && expr->op2->ts.type == BT_CHARACTER); + gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER + && expr->value.op.op2->ts.type == BT_CHARACTER); gfc_init_se (&lse, se); - gfc_conv_expr (&lse, expr->op1); + gfc_conv_expr (&lse, expr->value.op.op1); gfc_conv_string_parameter (&lse); gfc_init_se (&rse, se); - gfc_conv_expr (&rse, expr->op2); + gfc_conv_expr (&rse, expr->value.op.op2); gfc_conv_string_parameter (&rse); gfc_add_block_to_block (&se->pre, &lse.pre); @@ -846,10 +846,10 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) checkstring = 0; lop = 0; - switch (expr->operator) + switch (expr->value.op.operator) { case INTRINSIC_UPLUS: - gfc_conv_expr (se, expr->op1); + gfc_conv_expr (se, expr->value.op.op1); return; case INTRINSIC_UMINUS: @@ -951,19 +951,19 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) } /* The only exception to this is **, which is handled separately anyway. */ - gcc_assert (expr->op1->ts.type == expr->op2->ts.type); + gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type); - if (checkstring && expr->op1->ts.type != BT_CHARACTER) + if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER) checkstring = 0; /* lhs */ gfc_init_se (&lse, se); - gfc_conv_expr (&lse, expr->op1); + gfc_conv_expr (&lse, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &lse.pre); /* rhs */ gfc_init_se (&rse, se); - gfc_conv_expr (&rse, expr->op2); + gfc_conv_expr (&rse, expr->value.op.op2); gfc_add_block_to_block (&se->pre, &rse.pre); /* For string comparisons we generate a library call, and compare the return @@ -1220,7 +1220,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, something like x = f() where f is pointer valued, we have to dereference the result. */ - if (sym->attr.pointer && !se->want_pointer && !byref) + if (!se->want_pointer && !byref + && (sym->attr.pointer || (sym->result && sym->result->attr.pointer))) se->expr = gfc_build_indirect_ref (se->expr); /* A pure function may still have side-effects - it may modify its diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index dcabd4112fe..014709327b2 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1032,8 +1032,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) } -/* Create a symbol node for this intrinsic. The symbol form the frontend - is for the generic name. */ +/* Create a symbol node for this intrinsic. The symbol from the frontend + has the generic name. */ static gfc_symbol * gfc_get_symbol_for_expr (gfc_expr * expr) @@ -2649,11 +2649,10 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) } -/* Generate code for the IARGC intrinsic. If args_only is true this is - actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */ +/* Generate code for the IARGC intrinsic. */ static void -gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only) +gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) { tree tmp; tree fndecl; @@ -2667,8 +2666,6 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only) type = gfc_typenode_for_spec (&expr->ts); tmp = fold_convert (type, tmp); - if (args_only) - tmp = build2 (MINUS_EXPR, type, tmp, build_int_cst (type, 1)); se->expr = tmp; } @@ -2827,7 +2824,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_COMMAND_ARGUMENT_COUNT: - gfc_conv_intrinsic_iargc (se, expr, TRUE); + gfc_conv_intrinsic_iargc (se, expr); break; case GFC_ISYM_CONJG: @@ -2869,7 +2866,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_IARGC: - gfc_conv_intrinsic_iargc (se, expr, FALSE); + gfc_conv_intrinsic_iargc (se, expr); break; case GFC_ISYM_IEOR: @@ -2980,6 +2977,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 1); break; + case GFC_ISYM_CHDIR: case GFC_ISYM_DOT_PRODUCT: case GFC_ISYM_ETIME: case GFC_ISYM_FNUM: @@ -2988,12 +2986,20 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_GETGID: case GFC_ISYM_GETPID: case GFC_ISYM_GETUID: + case GFC_ISYM_HOSTNM: + case GFC_ISYM_KILL: + case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: + case GFC_ISYM_LINK: case GFC_ISYM_MATMUL: case GFC_ISYM_RAND: + case GFC_ISYM_RENAME: case GFC_ISYM_SECOND: case GFC_ISYM_STAT: + case GFC_ISYM_SYMLNK: case GFC_ISYM_SYSTEM: + case GFC_ISYM_TIME: + case GFC_ISYM_TIME8: case GFC_ISYM_UMASK: case GFC_ISYM_UNLINK: gfc_conv_intrinsic_funcall (se, expr); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b5ef13f5e16..416932173de 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -397,7 +397,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, tree len; gfc_init_se (&se, NULL); - gfc_conv_expr (&se, e); io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len, @@ -406,6 +405,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, /* Integer variable assigned a format label. */ if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) { + gfc_conv_label_variable (&se, e); msg = gfc_build_cstring_const ("Assigned label is not a format label"); tmp = GFC_DECL_STRING_LEN (se.expr); @@ -417,6 +417,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, } else { + gfc_conv_expr (&se, e); gfc_conv_string_parameter (&se); gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); gfc_add_modify_expr (&se.pre, len, se.string_length); @@ -816,7 +817,7 @@ gfc_trans_inquire (gfc_code * code) static gfc_expr * -gfc_new_nml_name_expr (char * name) +gfc_new_nml_name_expr (const char * name) { gfc_expr * nml_name; nml_name = gfc_get_expr(); @@ -825,7 +826,8 @@ gfc_new_nml_name_expr (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 = name; + nml_name->value.character.string = gfc_getmem (strlen (name) + 1); + strcpy (nml_name->value.character.string, name); return nml_name; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index da074c8b454..ea5da88fe7b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -80,7 +80,23 @@ gfc_trans_label_here (gfc_code * code) return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); } + +/* Given a variable expression which has been ASSIGNed to, find the decl + containing the auxiliary variables. For variables in common blocks this + is a field_decl. */ + +void +gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) +{ + gcc_assert (expr->symtree->n.sym->attr.assign == 1); + gfc_conv_expr (se, expr); + /* Deals with variable in common block. Get the field declaration. */ + if (TREE_CODE (se->expr) == COMPONENT_REF) + se->expr = TREE_OPERAND (se->expr, 1); +} + /* Translate a label assignment statement. */ + tree gfc_trans_label_assign (gfc_code * code) { @@ -95,7 +111,8 @@ gfc_trans_label_assign (gfc_code * code) /* Start a new block. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - gfc_conv_expr (&se, code->expr); + gfc_conv_label_variable (&se, code->expr); + len = GFC_DECL_STRING_LEN (se.expr); addr = GFC_DECL_ASSIGN_ADDR (se.expr); @@ -103,6 +120,8 @@ gfc_trans_label_assign (gfc_code * code) if (code->label->defined == ST_LABEL_TARGET) { + /* Shouldn't need to set this flag. Reserve for optimization bug. */ + DECL_ARTIFICIAL (label_tree) = 0; label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); len_tree = integer_minus_one_node; } @@ -140,7 +159,7 @@ gfc_trans_goto (gfc_code * code) /* ASSIGNED GOTO. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - gfc_conv_expr (&se, code->expr); + gfc_conv_label_variable (&se, code->expr); assign_error = gfc_build_cstring_const ("Assigned label is not a target label"); tmp = GFC_DECL_STRING_LEN (se.expr); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7bd0011ce8a..68262d6d161 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -81,6 +81,7 @@ int gfc_index_integer_kind; /* The default kinds of the various types. */ int gfc_default_integer_kind; +int gfc_max_integer_kind; int gfc_default_real_kind; int gfc_default_double_kind; int gfc_default_character_kind; @@ -135,6 +136,9 @@ gfc_init_kinds (void) i_index += 1; } + /* Set the maximum integer kind. Used with at least BOZ constants. */ + gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; + for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++) { const struct real_format *fmt = REAL_MODE_FORMAT (mode); @@ -183,10 +187,10 @@ gfc_init_kinds (void) /* Choose the default integer kind. We choose 4 unless the user directs us otherwise. */ - if (gfc_option.i8) + if (gfc_option.flag_default_integer) { if (!saw_i8) - fatal_error ("integer kind=8 not available for -i8 option"); + fatal_error ("integer kind=8 not available for -fdefault-integer-8 option"); gfc_default_integer_kind = 8; } else if (saw_i4) @@ -195,10 +199,10 @@ gfc_init_kinds (void) gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind; /* Choose the default real kind. Again, we choose 4 when possible. */ - if (gfc_option.r8) + if (gfc_option.flag_default_real) { if (!saw_r8) - fatal_error ("real kind=8 not available for -r8 option"); + fatal_error ("real kind=8 not available for -fdefault-real-8 option"); gfc_default_real_kind = 8; } else if (saw_r4) @@ -206,9 +210,16 @@ gfc_init_kinds (void) else gfc_default_real_kind = gfc_real_kinds[0].kind; - /* Choose the default double kind. If -r8 is specified, we use kind=16, - if it's available, otherwise we do not change anything. */ - if (gfc_option.r8 && saw_r16) + /* Choose the default double kind. If -fdefault-real and -fdefault-double + are specified, we use kind=8, if it's available. If -fdefault-real is + specified without -fdefault-double, we use kind=16, if it's available. + Otherwise we do not change anything. */ + if (gfc_option.flag_default_double && !gfc_option.flag_default_real) + fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8"); + + if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8) + gfc_default_double_kind = 8; + else if (gfc_option.flag_default_real && saw_r16) gfc_default_double_kind = 16; else if (saw_r4 && saw_r8) gfc_default_double_kind = 8; @@ -1667,4 +1678,24 @@ gfc_signed_type (tree type) return gfc_signed_or_unsigned_type (0, type); } +/* APPLE LOCAL kext */ +int flag_weak = 0; + +/* APPLE LOCAL constant cfstrings */ +struct cpp_reader* parse_in; + +/* APPLE LOCAL begin AltiVec */ +tree +build_stmt (enum tree_code code ATTRIBUTE_UNUSED, ...) +{ + gcc_assert(0); +} + +void +store_init_value (tree decl ATTRIBUTE_UNUSED, tree init ATTRIBUTE_UNUSED) +{ + gcc_assert(0); +} +/* APPLE LOCAL end AltiVec */ + #include "gt-fortran-trans-types.h" diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 647a62abc9a..36f4e4f841d 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -94,5 +94,9 @@ int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ tree gfc_get_dtype (tree); +/* APPLE LOCAL begin AltiVec */ +tree build_stmt (enum tree_code code ATTRIBUTE_UNUSED, ...); +void store_init_value (tree decl ATTRIBUTE_UNUSED, tree init ATTRIBUTE_UNUSED); +/* APPLE LOCAL end AltiVec */ #endif diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index b670f7a3888..712c530aaee 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -118,7 +118,7 @@ typedef enum scalarization loop. */ GFC_SS_SCALAR, - /* Like GFC_SS_SCALAR except it evaluates a pointer the the expression. + /* Like GFC_SS_SCALAR except it evaluates a pointer to the expression. Used for elemental function parameters. */ GFC_SS_REFERENCE, @@ -289,6 +289,8 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); /* Equivalent to convert(type, gfc_conv_expr_val(se, expr)). */ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); +/* Find the decl containing the auxiliary variables for assigned variables. */ +void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ tree gfc_evaluate_now (tree, stmtblock_t *); @@ -391,6 +393,9 @@ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); /* Restore the original variable. */ void gfc_restore_sym (gfc_symbol *, gfc_saved_var *); +/* Returns true if a variable of specified size should go on the stack. */ +int gfc_can_put_var_on_stack (tree); + /* Allocate the lang-spcific part of a decl node. */ void gfc_allocate_lang_decl (tree); |