summaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog170
-rw-r--r--gcc/fortran/Make-lang.in3
-rw-r--r--gcc/fortran/decl.c3
-rw-r--r--gcc/fortran/expr.c2
-rw-r--r--gcc/fortran/f95-lang.c24
-rw-r--r--gcc/fortran/gfortran.h9
-rw-r--r--gcc/fortran/interface.c26
-rw-r--r--gcc/fortran/intrinsic.c434
-rw-r--r--gcc/fortran/intrinsic.h1
-rw-r--r--gcc/fortran/intrinsic.texi266
-rw-r--r--gcc/fortran/iso-c-binding.def43
-rw-r--r--gcc/fortran/iso-fortran-env.def14
-rw-r--r--gcc/fortran/lang.opt2
-rw-r--r--gcc/fortran/misc.c13
-rw-r--r--gcc/fortran/module.c8
-rw-r--r--gcc/fortran/openmp.c3
-rw-r--r--gcc/fortran/options.c4
-rw-r--r--gcc/fortran/primary.c7
-rw-r--r--gcc/fortran/resolve.c42
-rw-r--r--gcc/fortran/simplify.c153
-rw-r--r--gcc/fortran/symbol.c1
-rw-r--r--gcc/fortran/trans-array.c7
-rw-r--r--gcc/fortran/trans-expr.c32
-rw-r--r--gcc/fortran/trans-types.c95
24 files changed, 1005 insertions, 357 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5b963a1d532..32c3192d297 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,139 @@
+2009-05-25 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40176
+ * primary.c (gfc_match_varspec): Handle procedure pointer components
+ with array return value.
+ * resolve.c (resolve_expr_ppc): Ditto.
+ (resolve_symbol): Make sure the interface of a procedure pointer has
+ been resolved.
+ * trans-array.c (gfc_walk_function_expr): Handle procedure pointer
+ components with array return value.
+ * trans-expr.c (gfc_conv_component_ref,gfc_conv_procedure_call,
+ gfc_trans_arrayfunc_assign): Ditto.
+ (gfc_trans_pointer_assignment): Handle procedure pointer assignments,
+ where the rhs is a dummy argument.
+ * trans-types.c (gfc_get_ppc_type,gfc_get_derived_type): Handle
+ procedure pointer components with array return value.
+
+2009-05-24 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+ Dominique Dhumieres
+
+ PR fortran/35732
+ PR fortran/39872
+ * trans-array.c (gfc_conv_ss_startstride): Add one to index.
+
+2009-05-22 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/40195
+ * module.c (read_md5_from_module_file): Close file before returning.
+
+2009-05-18 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40164
+ * primary.c (gfc_match_rvalue): Handle procedure pointer components in
+ arrays.
+ * resolve.c (resolve_ppc_call,resolve_expr_ppc): Resolve component and
+ array references.
+ (resolve_fl_derived): Procedure pointer components are not required to
+ have constant array bounds in their return value.
+
+2009-05-18 Janus Weil <janus@gcc.gnu.org>
+
+ * intrinsic.c (add_sym): Fix my last commit (r147655),
+ which broke bootstrap.
+
+2009-05-18 Richard Guenther <rguenther@suse.de>
+
+ PR fortran/40168
+ * trans-expr.c (gfc_trans_zero_assign): For local array
+ destinations use an assignment from an empty constructor.
+
+2009-05-18 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/36947
+ PR fortran/40039
+ * expr.c (gfc_check_pointer_assign): Check intents when comparing
+ interfaces.
+ * gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
+ (gfc_compare_interfaces): Additional argument.
+ * interface.c (operator_correspondence): Add check for equality of
+ intents, and new argument 'intent_check'.
+ (gfc_compare_interfaces): New argument 'intent_check', which is passed
+ on to operator_correspondence.
+ (check_interface1): Don't check intents when comparing interfaces.
+ (compare_parameter): Do check intents when comparing interfaces.
+ * intrinsic.c (add_sym): Add intents for arguments of intrinsic
+ procedures.
+ (add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
+ add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
+ default.
+ (add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
+ : New functions to add intrinsic symbols, specifying custom intents.
+ (add_sym_4s,add_sym_5s): Add new arguments to specify intents.
+ (add_functions,add_subroutines): Add intents for various intrinsics.
+ * resolve.c (check_generic_tbp_ambiguity): Don't check intents when
+ comparing interfaces.
+ * symbol.c (gfc_copy_formal_args_intr): Copy intent.
+
+2009-05-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ * iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32,
+ REAL64 and REAL128.
+ * gfortran.h (gfc_get_int_kind_from_width_isofortranenv,
+ gfc_get_real_kind_from_width_isofortranenv): New prototypes.
+ * iso-c-binding.def: Update definitions for the INT*_T,
+ INT_LEAST*_T and INT_FAST*_T named parameters.
+ * trans-types.c (get_typenode_from_name, get_int_kind_from_name,
+ gfc_get_real_kind_from_width_isofortranenv): New functions.
+
+2009-05-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/36260
+ * intrinsic.c (add_functions, add_subroutines): Fix argument
+ names and wrap long lines.
+ * intrinsic.texi: Fix documentation and argument names of
+ LOG_GAMMA, DATAN2, DBESJN, DTIME, ETIME, FSTAT, STAT, LSTAT,
+ GET_COMMAND, IDATE, LTIME, MOVE_ALLOC, NINT, OR, PRODUCT,
+ SUM, RAND, RANDOM_SEED, REAL, SELECTED_INT_KIND,
+ SELECTED_REAL_KIND and XOR.
+
+2009-05-16 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/33197
+ * intrinsic.c (add_functions): Use ERFC_SCALED simplification.
+ * intrinsic.h (gfc_simplify_erfc_scaled): New prototype.
+ * simplify.c (fullprec_erfc_scaled, asympt_erfc_scaled,
+ gfc_simplify_erfc_scaled): New functions.
+
+2009-05-16 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/31243
+ * resolve.c (resolve_substring): Don't allow too large substring
+ indexes.
+ (gfc_resolve_substring_charlen): Fix typo.
+ (gfc_resolve_character_operator): Fix typo.
+ (resolve_charlen): Catch unreasonably large string lengths.
+ * simplify.c (gfc_simplify_len): Don't error out on LEN
+ range checks.
+
+2009-05-16 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/36031
+ * decl.c (set_enum_kind): Use global short-enums flag.
+ * gfortran.h (gfc_option_t): Remove short_enums flag.
+ * lang.opt (-fshort-enums): Refer to C documentation.
+ * options.c (gfc_init_options, gfc_handle_option): Use global
+ short-enums flag.
+
+2009-05-15 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/39352
+ * f95-lang.c: Add gfc_maybe_initialize_eh.
+ * gfortran.h: Add gfc_maybe_initialize_eh prototype.
+ * Make-lang.in: Add new .h dendencies for f95-lang.c
+ * openmp.c (resolve_omp_do): Call gfc_maybe_initialize_eh.
+ * misc.c (gfc_free): Avoid #define trickery for free.
+
2009-05-14 Steven G. Kargl <kargl@gcc.gnu.org>
* dump-parse-tree.c (show_code_node): Add ERRMSG to the dumping
@@ -82,7 +218,7 @@
* gfortran.h (gfc_code): Rename struct member label to label1.
* dump-parse-tree.c (show_code_node): Update symbol.
* trans-stmt.c (gfc_trans_label_assign, gfc_trans_goto,
- gfc_trans_arithmetic_if)": Ditto.
+ gfc_trans_arithmetic_if): Ditto.
* resolve.c (gfc_resolve_blocks, resolve_code): Ditto.
* match.c (match_arithmetic_if, gfc_match_if, gfc_reference_st_label,
gfc_match_assign, gfc_match_goto): Ditto.
@@ -340,13 +476,13 @@
2009-04-24 Daniel Kraft <d@domob.eu>
* gfortran.h (gfc_get_typebound_proc): Removed as macro, now a function.
- (struct gfc_symtree): Moved `typebound' member inside union.
- (struct gfc_namespace): Add `tb_sym_root' as new symtree to sort out
+ (struct gfc_symtree): Moved "typebound" member inside union.
+ (struct gfc_namespace): Add "tb_sym_root" as new symtree to sort out
type-bound procedures there.
(gfc_get_tbp_symtree): New procedure.
* symbol.c (tentative_tbp_list): New global.
- (gfc_get_namespace): NULL new `tb_sym_root' member.
- (gfc_new_symtree): Removed initialization of `typebound' member.
+ (gfc_get_namespace): NULL new "tb_sym_root" member.
+ (gfc_new_symtree): Removed initialization of "typebound" member.
(gfc_undo_symbols): Process list of tentative tbp's.
(gfc_commit_symbols): Ditto.
(free_tb_tree): New method.
@@ -359,8 +495,8 @@
* primary.c (gfc_match_varspec): Ditto. Don't reference tbp-symbol
as it isn't a symbol any longer.
* module.c (mio_typebound_symtree): Adapt to changes.
- (mio_typebound_proc): Ditto, create symtrees using `gfc_get_tbp_symtree'
- rather than `gfc_get_sym_tree'.
+ (mio_typebound_proc): Ditto, create symtrees using "gfc_get_tbp_symtree"
+ rather than "gfc_get_sym_tree".
(mio_f2k_derived): Ditto.
* decl.c (match_procedure_in_type): Ditto.
(gfc_match_generic): Ditto. Don't reference tbp-symbol.
@@ -469,7 +605,7 @@
2009-04-11 Daniel Kraft <d@domob.eu>
PR fortran/37746
- * gfortran.h (struct gfc_charlen): New field `passed_length' to store
+ * gfortran.h (struct gfc_charlen): New field "passed_length" to store
the actual passed string length for dummy arguments.
* trans-decl.c (gfc_create_string_length): Formatting fixes and added
assertion, moved a local variable into the innermost block it is needed.
@@ -577,15 +713,15 @@
2009-04-06 Janus Weil <janus@gcc.gnu.org>
- PR fortran/39414
- * decl.c (match_procedure_decl): Fix double declaration problems with
- PROCEDURE statements.
- * symbol.c (gfc_add_type): Ditto.
+ PR fortran/39414
+ * decl.c (match_procedure_decl): Fix double declaration problems with
+ PROCEDURE statements.
+ * symbol.c (gfc_add_type): Ditto.
2009-04-06 Paul Thomas <pault@gcc.gnu.org>
- PR fortran/36091
- * trans-array.c (gfc_conv_array_ref): If the symbol has the
+ PR fortran/36091
+ * trans-array.c (gfc_conv_array_ref): If the symbol has the
temporary attribute use the array_spec for the bounds.
* gfortran.h : Add the temporary field to the structure
'symbol_attribute'.
@@ -714,7 +850,7 @@
2009-03-29 Daniel Kraft <d@domob.eu>
PR fortran/37423
- * gfortran.h (struct gfc_typebound_proc): Added new flag `deferred' and
+ * gfortran.h (struct gfc_typebound_proc): Added new flag "deferred" and
added a comment explaining DEFERRED binding handling.
* decl.c (match_binding_attributes): Really match DEFERRED attribute.
(match_procedure_in_type): Really match PROCEDURE(interface) syntax
@@ -726,7 +862,7 @@
(resolve_typebound_procedure): Allow abstract interfaces as targets
for DEFERRED bindings.
(ensure_not_abstract_walker), (ensure_not_abstract): New methods.
- (resolve_fl_derived): Use new `ensure_not_abstract' method for
+ (resolve_fl_derived): Use new "ensure_not_abstract" method for
non-ABSTRACT types extending ABSTRACT ones to ensure each DEFERRED
binding is overridden.
(check_typebound_baseobject): New method.
@@ -735,7 +871,7 @@
* gfc-internals.texi (Type-bound procedures): Document a little bit
about internal handling of DEFERRED bindings.
-2009-03-29 Tobias Schlüter <tobi@gcc.gnu.org>
+2009-03-29 Tobias Schlueter <tobi@gcc.gnu.org>
PR fortran/38507
* gfortran.h (gfc_st_label): Fix comment.
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index ba81b93b688..5885a621933 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -313,7 +313,8 @@ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \
fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) fortran/cpp.h \
- $(BUILTINS_DEF) fortran/types.def
+ $(BUILTINS_DEF) fortran/types.def \
+ libfuncs.h expr.h except.h
fortran/scanner.o: toplev.h fortran/cpp.h
fortran/convert.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans.o: $(GFORTRAN_TRANS_DEPS) tree-iterator.h
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a5261b8a862..7ecb921e0d3 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -24,6 +24,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h"
#include "match.h"
#include "parse.h"
+#include "flags.h"
/* Macros to access allocate memory for gfc_data_variable,
@@ -5295,7 +5296,7 @@ set_enum_kind(void)
if (max_enum == NULL || enum_history == NULL)
return;
- if (!gfc_option.fshort_enums)
+ if (!flag_short_enums)
return;
i = 0;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index feaa6254840..2c70ba6bb98 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS;
if (rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0))
+ rvalue->symtree->n.sym, 0, 1))
{
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 1aab3bf6cc3..97a071d06f9 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -43,6 +43,10 @@ along with GCC; see the file COPYING3. If not see
#include "diagnostic.h"
#include "tree-dump.h"
#include "cgraph.h"
+/* For gfc_maybe_initialize_eh. */
+#include "libfuncs.h"
+#include "expr.h"
+#include "except.h"
#include "gfortran.h"
#include "cpp.h"
@@ -165,6 +169,10 @@ static GTY(()) struct binding_level *free_binding_level;
It is indexed by a RID_... value. */
tree *ridpointers = NULL;
+/* True means we've initialized exception handling. */
+bool gfc_eh_initialized_p;
+
+
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
or validate its data type for an `if' or `while' statement or ?..: exp.
@@ -1223,5 +1231,21 @@ gfc_init_ts (void)
tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1;
}
+void
+gfc_maybe_initialize_eh (void)
+{
+ if (!flag_exceptions || gfc_eh_initialized_p)
+ return;
+
+ gfc_eh_initialized_p = true;
+ eh_personality_libfunc
+ = init_one_libfunc (USING_SJLJ_EXCEPTIONS
+ ? "__gcc_personality_sj0"
+ : "__gcc_personality_v0");
+ default_init_unwind_resume_libfunc ();
+ using_eh_for_cleanups ();
+}
+
+
#include "gt-fortran-f95-lang.h"
#include "gtype-fortran.h"
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 86f2c5bf252..8ed05f2d6dd 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1445,6 +1445,7 @@ typedef struct gfc_intrinsic_arg
gfc_typespec ts;
int optional;
+ ENUM_BITFIELD (sym_intent) intent:2;
gfc_actual_arglist *actual;
struct gfc_intrinsic_arg *next;
@@ -2060,7 +2061,6 @@ typedef struct
int warn_std;
int allow_std;
- int fshort_enums;
int convert;
int record_marker;
int max_subrecord_length;
@@ -2198,6 +2198,9 @@ unsigned int gfc_init_options (unsigned int, const char **);
int gfc_handle_option (size_t, const char *, int);
bool gfc_post_options (const char **);
+/* f95-lang.c */
+void gfc_maybe_initialize_eh (void);
+
/* iresolve.c */
const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1;
bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *);
@@ -2252,6 +2255,8 @@ bool gfc_check_character_range (gfc_char_t, int);
/* trans-types.c */
gfc_try gfc_check_any_c_kind (gfc_typespec *);
int gfc_validate_kind (bt, int, bool);
+int gfc_get_int_kind_from_width_isofortranenv (int size);
+int gfc_get_real_kind_from_width_isofortranenv (int size);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
extern int gfc_max_integer_kind;
@@ -2562,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f2d14657f06..48c026cb2fe 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
which makes this test much easier than that for generic tests.
This subroutine is also used when comparing a formal and actual
- argument list when an actual parameter is a dummy procedure. At
- that point, two formal interfaces must be compared for equality
- which is what happens here. */
+ argument list when an actual parameter is a dummy procedure, and in
+ procedure pointer assignments. In these cases, two formal interfaces must be
+ compared for equality which is what happens here. 'intent_flag' specifies
+ whether the intents of the arguments are required to match, which is not the
+ case for ambiguity checks. */
static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
+operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+ int intent_flag)
{
for (;;)
{
+ /* Check existence. */
if (f1 == NULL && f2 == NULL)
break;
if (f1 == NULL || f2 == NULL)
return 1;
+ /* Check type and rank. */
if (!compare_type_rank (f1->sym, f2->sym))
return 1;
+ /* Check intent. */
+ if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+ return 1;
+
f1 = f1->next;
f2 = f2->next;
}
@@ -961,7 +970,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
would be ambiguous between the two interfaces, zero otherwise. */
int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
+ int intent_flag)
{
gfc_formal_arglist *f1, *f2;
@@ -1001,7 +1011,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
}
else
{
- if (operator_correspondence (f1, f2))
+ if (operator_correspondence (f1, f2, intent_flag))
return 0;
}
@@ -1080,7 +1090,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
+ if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
{
if (referenced)
{
@@ -1362,7 +1372,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */
- if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
+ if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
goto proc_fail;
return 1;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ca125a36335..0b16a727778 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -227,11 +227,12 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
simplify pointer to simplification function
resolve pointer to resolution function
- Optional arguments come in multiples of four:
- char * name of argument
- bt type of argument
- int kind of argument
- int arg optional flag (1=optional, 0=required)
+ Optional arguments come in multiples of five:
+ char * name of argument
+ bt type of argument
+ int kind of argument
+ int arg optional flag (1=optional, 0=required)
+ sym_intent intent of argument
The sequence is terminated by a NULL name.
@@ -249,6 +250,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
{
char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */
int optional, first_flag;
+ sym_intent intent;
va_list argp;
switch (sizing)
@@ -301,6 +303,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
type = (bt) va_arg (argp, int);
kind = va_arg (argp, int);
optional = va_arg (argp, int);
+ intent = (sym_intent) va_arg (argp, int);
if (sizing != SZ_NOTHING)
nargs++;
@@ -319,6 +322,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
next_arg->ts.type = type;
next_arg->ts.kind = kind;
next_arg->optional = optional;
+ next_arg->intent = intent;
}
}
@@ -390,7 +394,7 @@ add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
rf.f1 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
+ a1, type1, kind1, optional1, INTENT_IN,
(void *) 0);
}
@@ -414,7 +418,59 @@ add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
+ a1, type1, kind1, optional1, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+ 1 arguments, specifying the intent of the argument. */
+
+static void
+add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
+ int actual_ok, bt type, int kind, int standard,
+ gfc_try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ sym_intent intent1)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f1 = check;
+ sf.f1 = simplify;
+ rf.f1 = resolve;
+
+ add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 1 arguments, specifying the intent of the argument. */
+
+static void
+add_sym_1s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
+ int kind, int standard,
+ gfc_try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ sym_intent intent1)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f1 = check;
+ sf.f1 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
(void *) 0);
}
@@ -440,8 +496,8 @@ add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt t
rf.f1m = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
(void *) 0);
}
@@ -467,8 +523,8 @@ add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
rf.f2 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
(void *) 0);
}
@@ -493,8 +549,36 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 2 arguments, specifying the intent of the arguments. */
+
+static void
+add_sym_2s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
+ int kind, int standard,
+ gfc_try (*check) (gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ sym_intent intent1, const char *a2, bt type2, int kind2,
+ int optional2, sym_intent intent2)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f2 = check;
+ sf.f2 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
(void *) 0);
}
@@ -521,9 +605,9 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -550,9 +634,9 @@ add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -579,9 +663,9 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -607,9 +691,39 @@ add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 3 arguments, specifying the intent of the arguments. */
+
+static void
+add_sym_3s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
+ int kind, int standard,
+ gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ sym_intent intent1, const char *a2, bt type2, int kind2,
+ int optional2, sym_intent intent2, const char *a3, bt type3,
+ int kind3, int optional3, sym_intent intent3)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f3 = check;
+ sf.f3 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
(void *) 0);
}
@@ -639,10 +753,10 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
rf.f4 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
+ a4, type4, kind4, optional4, INTENT_IN,
(void *) 0);
}
@@ -651,15 +765,17 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
4 arguments. */
static void
-add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
+add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
+ int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1,
- const char *a2, bt type2, int kind2, int optional2,
- const char *a3, bt type3, int kind3, int optional3,
- const char *a4, bt type4, int kind4, int optional4)
+ sym_intent intent1, const char *a2, bt type2, int kind2,
+ int optional2, sym_intent intent2, const char *a3, bt type3,
+ int kind3, int optional3, sym_intent intent3, const char *a4,
+ bt type4, int kind4, int optional4, sym_intent intent4)
{
gfc_check_f cf;
gfc_simplify_f sf;
@@ -670,10 +786,10 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
+ a4, type4, kind4, optional4, intent4,
(void *) 0);
}
@@ -682,17 +798,20 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
5 arguments. */
static void
-add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
+add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
+ int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *),
void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1,
- const char *a2, bt type2, int kind2, int optional2,
- const char *a3, bt type3, int kind3, int optional3,
- const char *a4, bt type4, int kind4, int optional4,
- const char *a5, bt type5, int kind5, int optional5)
+ sym_intent intent1, const char *a2, bt type2, int kind2,
+ int optional2, sym_intent intent2, const char *a3, bt type3,
+ int kind3, int optional3, sym_intent intent3, const char *a4,
+ bt type4, int kind4, int optional4, sym_intent intent4,
+ const char *a5, bt type5, int kind5, int optional5,
+ sym_intent intent5)
{
gfc_check_f cf;
gfc_simplify_f sf;
@@ -703,11 +822,11 @@ add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
- a5, type5, kind5, optional5,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
+ a4, type4, kind4, optional4, intent4,
+ a5, type5, kind5, optional5, intent5,
(void *) 0);
}
@@ -962,7 +1081,8 @@ add_functions (void)
*x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
*y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
*z = "z", *ln = "len", *ut = "unit", *han = "handler",
- *num = "number", *tm = "time", *nm = "name", *md = "mode";
+ *num = "number", *tm = "time", *nm = "name", *md = "mode",
+ *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command";
int di, dr, dd, dl, dc, dz, ii;
@@ -1431,8 +1551,9 @@ add_functions (void)
make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008);
add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO,
- BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r, NULL,
- gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
+ BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r,
+ gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL,
+ dr, REQUIRED);
make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008);
@@ -1499,9 +1620,9 @@ add_functions (void)
make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
- add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_fstat, NULL, gfc_resolve_fstat,
- a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+ add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_fstat, NULL, gfc_resolve_fstat,
+ ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
@@ -1850,9 +1971,9 @@ add_functions (void)
make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
- add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_link, NULL, gfc_resolve_link,
- a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
+ add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
@@ -1900,15 +2021,15 @@ add_functions (void)
make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
- add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_stat, NULL, gfc_resolve_lstat,
- a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+ add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_lstat,
+ nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
- add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
- gfc_check_malloc, NULL, gfc_resolve_malloc, a, BT_INTEGER, di,
- REQUIRED);
+ add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
+ GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc,
+ sz, BT_INTEGER, di, REQUIRED);
make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
@@ -1967,13 +2088,13 @@ add_functions (void)
make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
- add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- NULL, NULL, gfc_resolve_mclock);
+ add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
- add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- NULL, NULL, gfc_resolve_mclock8);
+ add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
@@ -2100,9 +2221,9 @@ add_functions (void)
make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
- add_sym_1 ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
- gfc_check_present, NULL, NULL,
- a, BT_REAL, dr, REQUIRED);
+ add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO,
+ BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL,
+ a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
@@ -2155,9 +2276,9 @@ add_functions (void)
make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
- add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_rename, NULL, gfc_resolve_rename,
- a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
+ add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
@@ -2338,9 +2459,9 @@ add_functions (void)
make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
- add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_stat, NULL, gfc_resolve_stat,
- a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+ add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_stat,
+ nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
@@ -2351,15 +2472,15 @@ add_functions (void)
make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
- add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_symlnk, NULL, gfc_resolve_symlnk,
- a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
+ add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
- add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- NULL, NULL, NULL,
- c, BT_CHARACTER, dc, REQUIRED);
+ add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, NULL, NULL, NULL,
+ com, BT_CHARACTER, dc, REQUIRED);
make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
@@ -2440,16 +2561,16 @@ add_functions (void)
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
/* g77 compatibility for UMASK. */
- add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
- gfc_check_umask, NULL, gfc_resolve_umask,
- a, BT_INTEGER, di, REQUIRED);
+ add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
+ GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
+ msk, BT_INTEGER, di, REQUIRED);
make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
/* g77 compatibility for UNLINK. */
add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_unlink, NULL, gfc_resolve_unlink,
- a, BT_CHARACTER, dc, REQUIRED);
+ "path", BT_CHARACTER, dc, REQUIRED);
make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
@@ -2468,9 +2589,9 @@ add_functions (void)
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
- add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
- gfc_check_loc, NULL, gfc_resolve_loc,
- ar, BT_UNKNOWN, 0, REQUIRED);
+ add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
+ GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
+ x, BT_UNKNOWN, 0, REQUIRED);
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
}
@@ -2491,7 +2612,8 @@ add_subroutines (void)
*val = "value", *num = "number", *name = "name",
*trim_name = "trim_name", *ut = "unit", *han = "handler",
*sec = "seconds", *res = "result", *of = "offset", *md = "mode",
- *whence = "whence", *pos = "pos";
+ *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
+ *p2 = "path2", *msk = "mask", *old = "old";
int di, dr, dc, dl, ii;
@@ -2505,9 +2627,10 @@ add_subroutines (void)
make_noreturn();
- add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
- tm, BT_REAL, dr, REQUIRED);
+ add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0,
+ GFC_STD_F95, gfc_check_cpu_time, NULL,
+ gfc_resolve_cpu_time,
+ tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2543,10 +2666,12 @@ add_subroutines (void)
name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
- add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_date_and_time, NULL, NULL,
- dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
- zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
+ add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0,
+ GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
+ dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2584,46 +2709,56 @@ add_subroutines (void)
/* F2003 commandline routines. */
- add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
- NULL, NULL, gfc_resolve_get_command,
- com, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL,
- st, BT_INTEGER, di, OPTIONAL);
+ add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN,
+ 0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_command,
+ com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
- add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
- NULL, NULL, gfc_resolve_get_command_argument,
- num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
+ add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS,
+ BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
+ gfc_resolve_get_command_argument,
+ num, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* F2003 subroutine to get environment variables. */
- add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
+ add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
+ NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_environment_variable,
- name, BT_CHARACTER, dc, REQUIRED,
- val, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
- trim_name, BT_LOGICAL, dl, OPTIONAL);
-
- add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
- gfc_check_move_alloc, NULL, NULL,
- f, BT_UNKNOWN, 0, REQUIRED,
- t, BT_UNKNOWN, 0, REQUIRED);
-
- add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
- f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
- ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
- tp, BT_INTEGER, di, REQUIRED);
-
- add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_random_number, NULL, gfc_resolve_random_number,
- h, BT_REAL, dr, REQUIRED);
-
- add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
- BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_random_seed, NULL, gfc_resolve_random_seed,
- sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
- gt, BT_INTEGER, di, OPTIONAL);
+ name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
+
+ add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0,
+ GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL,
+ f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
+ t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
+
+ add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
+ GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits,
+ gfc_resolve_mvbits,
+ f, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+ tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+ add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS,
+ BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_random_number, NULL,
+ gfc_resolve_random_number,
+ h, BT_REAL, dr, REQUIRED, INTENT_OUT);
+
+ add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
+ BT_UNKNOWN, 0, GFC_STD_F95,
+ gfc_check_random_seed, NULL, gfc_resolve_random_seed,
+ sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2633,7 +2768,7 @@ add_subroutines (void)
add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU,
gfc_check_srand, NULL, gfc_resolve_srand,
- c, BT_INTEGER, 4, REQUIRED);
+ "seed", BT_INTEGER, 4, REQUIRED);
add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_exit, NULL, gfc_resolve_exit,
@@ -2663,13 +2798,16 @@ add_subroutines (void)
gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
- add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
- NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
+ add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
+ gfc_check_free, NULL, gfc_resolve_free,
+ ptr, BT_INTEGER, ii, REQUIRED);
add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
- ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, di, REQUIRED,
- whence, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
+ ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ of, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
@@ -2685,21 +2823,21 @@ add_subroutines (void)
add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_link_sub, NULL, gfc_resolve_link_sub,
- name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_perror, NULL, gfc_resolve_perror,
- c, BT_CHARACTER, dc, REQUIRED);
+ "string", BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
- name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
- val, BT_INTEGER, di, REQUIRED);
+ sec, BT_INTEGER, di, REQUIRED);
add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
@@ -2723,17 +2861,19 @@ add_subroutines (void)
add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
- name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
+ p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_system_sub,
com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
- add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_system_clock, NULL, gfc_resolve_system_clock,
- c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
- cm, BT_INTEGER, di, OPTIONAL);
+ add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS,
+ BT_UNKNOWN, 0, GFC_STD_F95,
+ gfc_check_system_clock, NULL, gfc_resolve_system_clock,
+ c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
@@ -2741,11 +2881,11 @@ add_subroutines (void)
add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
- val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
+ msk, BT_INTEGER, di, REQUIRED, old, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
- c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
+ "path", BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
}
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 83c5207785b..7e8bc73ec6f 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -232,6 +232,7 @@ gfc_expr *gfc_simplify_dprod (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_epsilon (gfc_expr *);
gfc_expr *gfc_simplify_erf (gfc_expr *);
gfc_expr *gfc_simplify_erfc (gfc_expr *);
+gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
gfc_expr *gfc_simplify_exp (gfc_expr *);
gfc_expr *gfc_simplify_exponent (gfc_expr *);
gfc_expr *gfc_simplify_float (gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 06cdff0c828..d560af78b37 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -167,7 +167,6 @@ Some basic guidelines for editing this document:
* @code{LEADZ}: LEADZ, Number of leading zero bits of an integer
* @code{LEN}: LEN, Length of a character entity
* @code{LEN_TRIM}: LEN_TRIM, Length of a character entity without trailing blank characters
-* @code{LOG_GAMMA}: LOG_GAMMA, Logarithm of the Gamma function
* @code{LGE}: LGE, Lexical greater than or equal
* @code{LGT}: LGT, Lexical greater than
* @code{LINK}: LINK, Create a hard link
@@ -177,6 +176,7 @@ Some basic guidelines for editing this document:
* @code{LOC}: LOC, Returns the address of a variable
* @code{LOG}: LOG, Logarithm function
* @code{LOG10}: LOG10, Base 10 logarithm function
+* @code{LOG_GAMMA}: LOG_GAMMA, Logarithm of the Gamma function
* @code{LOGICAL}: LOGICAL, Convert to logical type
* @code{LONG}: LONG, Convert to integer type
* @code{LSHIFT}: LSHIFT, Left shift bits
@@ -1435,7 +1435,7 @@ end program test_atan2
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@item Name @tab Argument @tab Return type @tab Standard
-@item @code{DATAN2(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later
+@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X}, @code{REAL(8) Y} @tab @code{REAL(8)} @tab Fortran 77 and later
@end multitable
@end table
@@ -1634,9 +1634,9 @@ end program test_besjn
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
-@item Name @tab Argument @tab Return type @tab Standard
-@item @code{DBESJN(X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension
-@item @tab @code{REAL(8) X} @tab @tab
+@item Name @tab Argument @tab Return type @tab Standard
+@item @code{DBESJN(N, X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension
+@item @tab @code{REAL(8) X} @tab @tab
@end multitable
@end table
@@ -2488,7 +2488,7 @@ Inquiry function
@end multitable
@item @emph{Return value}:
-The return value is of type @code{INTEGER(4)}
+The return value is an @code{INTEGER} of default kind.
@item @emph{Example}:
@smallexample
@@ -3397,11 +3397,11 @@ end program test_dreal
@table @asis
@item @emph{Description}:
-@code{DTIME(TARRAY, RESULT)} initially returns the number of seconds of runtime
-since the start of the process's execution in @var{RESULT}. @var{TARRAY}
-returns the user and system components of this time in @code{TARRAY(1)} and
-@code{TARRAY(2)} respectively. @var{RESULT} is equal to @code{TARRAY(1) +
-TARRAY(2)}.
+@code{DTIME(VALUES, TIME)} initially returns the number of seconds of runtime
+since the start of the process's execution in @var{TIME}. @var{VALUES}
+returns the user and system components of this time in @code{VALUES(1)} and
+@code{VALUES(2)} respectively. @var{TIME} is equal to @code{VALUES(1) +
+VALUES(2)}.
Subsequent invocations of @code{DTIME} return values accumulated since the
previous invocation.
@@ -3421,12 +3421,12 @@ results. If possible, use @code{CPU_TIME} instead.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
-@var{TARRAY} and @var{RESULT} are @code{INTENT(OUT)} and provide the following:
+@var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following:
@multitable @columnfractions .15 .30 .40
-@item @tab @code{TARRAY(1)}: @tab User time in seconds.
-@item @tab @code{TARRAY(2)}: @tab System time in seconds.
-@item @tab @code{RESULT}: @tab Run time since start in seconds.
+@item @tab @code{VALUES(1)}: @tab User time in seconds.
+@item @tab @code{VALUES(2)}: @tab System time in seconds.
+@item @tab @code{TIME}: @tab Run time since start in seconds.
@end multitable
@item @emph{Standard}:
@@ -3437,14 +3437,14 @@ Subroutine, function
@item @emph{Syntax}:
@multitable @columnfractions .80
-@item @code{CALL DTIME(TARRAY, RESULT)}.
-@item @code{RESULT = DTIME(TARRAY)}, (not recommended).
+@item @code{CALL DTIME(VALUES, TIME)}.
+@item @code{TIME = DTIME(VALUES)}, (not recommended).
@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{TARRAY}@tab The type shall be @code{REAL, DIMENSION(2)}.
-@item @var{RESULT}@tab The type shall be @code{REAL}.
+@item @var{VALUES}@tab The type shall be @code{REAL, DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL}.
@end multitable
@item @emph{Return value}:
@@ -3716,10 +3716,10 @@ end program test_erfc_scaled
@table @asis
@item @emph{Description}:
-@code{ETIME(TARRAY, RESULT)} returns the number of seconds of runtime
-since the start of the process's execution in @var{RESULT}. @var{TARRAY}
-returns the user and system components of this time in @code{TARRAY(1)} and
-@code{TARRAY(2)} respectively. @var{RESULT} is equal to @code{TARRAY(1) + TARRAY(2)}.
+@code{ETIME(VALUES, TIME)} returns the number of seconds of runtime
+since the start of the process's execution in @var{TIME}. @var{VALUES}
+returns the user and system components of this time in @code{VALUES(1)} and
+@code{VALUES(2)} respectively. @var{TIME} is equal to @code{VALUES(1) + VALUES(2)}.
On some systems, the underlying timings are represented using types with
sufficiently small limits that overflows (wrap around) are possible, such as
@@ -3730,12 +3730,12 @@ run of the compiled program.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
-@var{TARRAY} and @var{RESULT} are @code{INTENT(OUT)} and provide the following:
+@var{VALUES} and @var{TIME} are @code{INTENT(OUT)} and provide the following:
@multitable @columnfractions .15 .30 .60
-@item @tab @code{TARRAY(1)}: @tab User time in seconds.
-@item @tab @code{TARRAY(2)}: @tab System time in seconds.
-@item @tab @code{RESULT}: @tab Run time since start in seconds.
+@item @tab @code{VALUES(1)}: @tab User time in seconds.
+@item @tab @code{VALUES(2)}: @tab System time in seconds.
+@item @tab @code{TIME}: @tab Run time since start in seconds.
@end multitable
@item @emph{Standard}:
@@ -3746,14 +3746,14 @@ Subroutine, function
@item @emph{Syntax}:
@multitable @columnfractions .80
-@item @code{CALL ETIME(TARRAY, RESULT)}.
-@item @code{RESULT = ETIME(TARRAY)}, (not recommended).
+@item @code{CALL ETIME(VALUES, TIME)}.
+@item @code{TIME = ETIME(VALUES)}, (not recommended).
@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{TARRAY}@tab The type shall be @code{REAL, DIMENSION(2)}.
-@item @var{RESULT}@tab The type shall be @code{REAL}.
+@item @var{VALUES}@tab The type shall be @code{REAL, DIMENSION(2)}.
+@item @var{TIME}@tab The type shall be @code{REAL}.
@end multitable
@item @emph{Return value}:
@@ -4557,7 +4557,7 @@ END PROGRAM
@code{FSTAT} is identical to @ref{STAT}, except that information about an
already opened file is obtained.
-The elements in @code{BUFF} are the same as described by @ref{STAT}.
+The elements in @code{VALUES} are the same as described by @ref{STAT}.
This intrinsic is provided in both subroutine and function forms; however,
only one form can be used in any given program unit.
@@ -4569,12 +4569,12 @@ GNU extension
Subroutine, function
@item @emph{Syntax}:
-@code{CALL FSTAT(UNIT, BUFF [, STATUS])}
+@code{CALL FSTAT(UNIT, VALUES [, STATUS])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{UNIT} @tab An open I/O unit number of type @code{INTEGER}.
-@item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
on success and a system specific error code otherwise.
@end multitable
@@ -4817,18 +4817,24 @@ Fortran 2003 and later
Subroutine
@item @emph{Syntax}:
-@code{CALL GET_COMMAND(COMMAND)}
+@code{CALL GET_COMMAND([COMMAND, LENGTH, STATUS])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{COMMAND} @tab Shall be of type @code{CHARACTER} and of default
-kind.
+@item @var{COMMAND} @tab (Optional) shall be of type @code{CHARACTER} and
+of default kind.
+@item @var{LENGTH} @tab (Optional) Shall be of type @code{INTEGER} and of
+default kind.
+@item @var{STATUS} @tab (Optional) Shall be of type @code{INTEGER} and of
+default kind.
@end multitable
@item @emph{Return value}:
-Stores the entire command line that was used to invoke the program in
-@var{COMMAND}. If @var{COMMAND} is not large enough, the command will be
-truncated.
+If @var{COMMAND} is present, stores the entire command line that was used
+to invoke the program in @var{COMMAND}. If @var{LENGTH} is present, it is
+assigned the length of the command line. If @var{STATUS} is present, it
+is assigned 0 upon success of the command, -1 if @var{COMMAND} is too
+short to store the command line, or a positive value in case of an error.
@item @emph{Example}:
@smallexample
@@ -4867,12 +4873,14 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER(4)},
-@math{@var{NUMBER} \geq 0}
+@item @var{NUMBER} @tab Shall be a scalar of type @code{INTEGER} and of
+default kind, @math{@var{NUMBER} \geq 0}
@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER}
and of default kind.
-@item @var{LENGTH} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}.
-@item @var{STATUS} @tab (Option) Shall be a scalar of type @code{INTEGER(4)}.
+@item @var{LENGTH} @tab (Option) Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{STATUS} @tab (Option) Shall be a scalar of type @code{INTEGER}
+and of default kind.
@end multitable
@item @emph{Return value}:
@@ -5022,11 +5030,16 @@ Subroutine
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{NAME} @tab Shall be a scalar of type @code{CHARACTER(1)}.
-@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER(1)}.
-@item @var{LENGTH} @tab Shall be a scalar of type @code{INTEGER(4)}.
-@item @var{STATUS} @tab Shall be a scalar of type @code{INTEGER(4)}.
-@item @var{TRIM_NAME} @tab Shall be a scalar of type @code{LOGICAL(4)}.
+@item @var{NAME} @tab Shall be a scalar of type @code{CHARACTER}
+and of default kind.
+@item @var{VALUE} @tab Shall be a scalar of type @code{CHARACTER}
+and of default kind.
+@item @var{LENGTH} @tab Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{STATUS} @tab Shall be a scalar of type @code{INTEGER}
+and of default kind.
+@item @var{TRIM_NAME} @tab Shall be a scalar of type @code{LOGICAL}
+and of default kind.
@end multitable
@item @emph{Return value}:
@@ -5707,9 +5720,9 @@ end program read_val
@table @asis
@item @emph{Description}:
-@code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the
+@code{IDATE(VALUES)} Fills @var{VALUES} with the numerical values at the
current local time. The day (in the range 1-31), month (in the range 1-12),
-and year appear in elements 1, 2, and 3 of @var{TARRAY}, respectively.
+and year appear in elements 1, 2, and 3 of @var{VALUES}, respectively.
The year has four significant digits.
@item @emph{Standard}:
@@ -7212,13 +7225,14 @@ The return value is of type @code{INTEGER} and of the same kind as
@table @asis
@item @emph{Description}:
-@code{LSTAT} is identical to @ref{STAT}, except that if path is a symbolic link,
-then the link itself is statted, not the file that it refers to.
+@code{LSTAT} is identical to @ref{STAT}, except that if path is a
+symbolic link, then the link itself is statted, not the file that it
+refers to.
-The elements in @code{BUFF} are the same as described by @ref{STAT}.
+The elements in @code{VALUES} are the same as described by @ref{STAT}.
-This intrinsic is provided in both subroutine and function forms; however,
-only one form can be used in any given program unit.
+This intrinsic is provided in both subroutine and function forms;
+however, only one form can be used in any given program unit.
@item @emph{Standard}:
GNU extension
@@ -7227,13 +7241,13 @@ GNU extension
Subroutine, function
@item @emph{Syntax}:
-@code{CALL LSTAT(FILE, BUFF [, STATUS])}
+@code{CALL LSTAT(NAME, VALUES [, STATUS])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{FILE} @tab The type shall be @code{CHARACTER} of the default
+@item @var{NAME} @tab The type shall be @code{CHARACTER} of the default
kind, a valid path within the file system.
-@item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}.
Returns 0 on success and a system specific error code otherwise.
@end multitable
@@ -7254,8 +7268,8 @@ To stat an open file: @ref{FSTAT}, to stat a file: @ref{STAT}
@table @asis
@item @emph{Description}:
-Given a system time value @var{STIME} (as provided by the @code{TIME8()}
-intrinsic), fills @var{TARRAY} with values extracted from it appropriate
+Given a system time value @var{TIME} (as provided by the @code{TIME8()}
+intrinsic), fills @var{VALUES} with values extracted from it appropriate
to the local time zone using @code{localtime(3)}.
@item @emph{Standard}:
@@ -7265,18 +7279,18 @@ GNU extension
Subroutine
@item @emph{Syntax}:
-@code{CALL LTIME(STIME, TARRAY)}
+@code{CALL LTIME(TIME, VALUES)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{STIME} @tab An @code{INTEGER} scalar expression
+@item @var{TIME} @tab An @code{INTEGER} scalar expression
corresponding to a system time, with @code{INTENT(IN)}.
-@item @var{TARRAY} @tab A default @code{INTEGER} array with 9 elements,
+@item @var{VALUES} @tab A default @code{INTEGER} array with 9 elements,
with @code{INTENT(OUT)}.
@end multitable
@item @emph{Return value}:
-The elements of @var{TARRAY} are assigned as follows:
+The elements of @var{VALUES} are assigned as follows:
@enumerate
@item Seconds after the minute, range 0--59 or 0--61 to allow for leap
seconds
@@ -8046,8 +8060,8 @@ end program
@table @asis
@item @emph{Description}:
-@code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to
-@var{DEST}. @var{SRC} will become deallocated in the process.
+@code{MOVE_ALLOC(FROM, TO)} moves the allocation from @var{FROM} to
+@var{TO}. @var{FROM} will become deallocated in the process.
@item @emph{Standard}:
Fortran 2003 and later
@@ -8056,14 +8070,14 @@ Fortran 2003 and later
Subroutine
@item @emph{Syntax}:
-@code{CALL MOVE_ALLOC(SRC, DEST)}
+@code{CALL MOVE_ALLOC(FROM, TO)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be
+@item @var{FROM} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be
of any type and kind.
-@item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be
-of the same type, kind and rank as @var{SRC}.
+@item @var{TO} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be
+of the same type, kind and rank as @var{FROM}.
@end multitable
@item @emph{Return value}:
@@ -8219,7 +8233,7 @@ end program newline
@table @asis
@item @emph{Description}:
-@code{NINT(X)} rounds its argument to the nearest whole number.
+@code{NINT(A)} rounds its argument to the nearest whole number.
@item @emph{Standard}:
Fortran 77 and later, with @var{KIND} argument Fortran 90 and later
@@ -8228,11 +8242,11 @@ Fortran 77 and later, with @var{KIND} argument Fortran 90 and later
Elemental function
@item @emph{Syntax}:
-@code{RESULT = NINT(X [, KIND])}
+@code{RESULT = NINT(A [, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{X} @tab The type of the argument shall be @code{REAL}.
+@item @var{A} @tab The type of the argument shall be @code{REAL}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of the result.
@end multitable
@@ -8368,13 +8382,13 @@ GNU extension
Function
@item @emph{Syntax}:
-@code{RESULT = OR(X, Y)}
+@code{RESULT = OR(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{X} @tab The type shall be either a scalar @code{INTEGER}
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
type or a scalar @code{LOGICAL} type.
-@item @var{Y} @tab The type shall be the same as the type of @var{X}.
+@item @var{J} @tab The type shall be the same as the type of @var{J}.
@end multitable
@item @emph{Return value}:
@@ -8606,8 +8620,10 @@ Fortran 95 and later
Transformational function
@item @emph{Syntax}:
-@code{RESULT = PRODUCT(ARRAY[, MASK])}
-@code{RESULT = PRODUCT(ARRAY, DIM[, MASK])}
+@multitable @columnfractions .80
+@item @code{RESULT = PRODUCT(ARRAY[, MASK])}
+@item @code{RESULT = PRODUCT(ARRAY, DIM[, MASK])}
+@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@@ -8732,11 +8748,11 @@ GNU extension
Function
@item @emph{Syntax}:
-@code{RESULT = RAND(FLAG)}
+@code{RESULT = RAND(I)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{FLAG} @tab Shall be a scalar @code{INTEGER} of kind 4.
+@item @var{I} @tab Shall be a scalar @code{INTEGER} of kind 4.
@end multitable
@item @emph{Return value}:
@@ -8839,7 +8855,7 @@ Fortran 95 and later
Subroutine
@item @emph{Syntax}:
-@code{CALL RANDOM_SEED(SIZE, PUT, GET)}
+@code{CALL RANDOM_SEED([SIZE, PUT, GET])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@@ -8924,8 +8940,8 @@ See @code{PRECISION} for an example.
@table @asis
@item @emph{Description}:
-@code{REAL(X [, KIND])} converts its argument @var{X} to a real type. The
-@code{REALPART(X)} function is provided for compatibility with @command{g77},
+@code{REAL(A [, KIND])} converts its argument @var{A} to a real type. The
+@code{REALPART} function is provided for compatibility with @command{g77},
and its use is strongly discouraged.
@item @emph{Standard}:
@@ -8936,13 +8952,13 @@ Elemental function
@item @emph{Syntax}:
@multitable @columnfractions .80
-@item @code{RESULT = REAL(X [, KIND])}
+@item @code{RESULT = REAL(A [, KIND])}
@item @code{RESULT = REALPART(Z)}
@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{X} @tab Shall be @code{INTEGER}, @code{REAL}, or
+@item @var{A} @tab Shall be @code{INTEGER}, @code{REAL}, or
@code{COMPLEX}.
@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
expression indicating the kind parameter of the result.
@@ -8954,14 +8970,14 @@ the following rules:
@table @asis
@item (A)
-@code{REAL(X)} is converted to a default real type if @var{X} is an
+@code{REAL(A)} is converted to a default real type if @var{A} is an
integer or real variable.
@item (B)
-@code{REAL(X)} is converted to a real type with the kind type parameter
-of @var{X} if @var{X} is a complex variable.
+@code{REAL(A)} is converted to a real type with the kind type parameter
+of @var{A} if @var{A} is a complex variable.
@item (C)
-@code{REAL(X, KIND)} is converted to a real type with kind type
-parameter @var{KIND} if @var{X} is a complex, integer, or real
+@code{REAL(A, KIND)} is converted to a real type with kind type
+parameter @var{KIND} if @var{A} is a complex, integer, or real
variable.
@end table
@@ -9432,9 +9448,9 @@ end program ascii_kind
@table @asis
@item @emph{Description}:
-@code{SELECTED_INT_KIND(I)} return the kind value of the smallest integer
-type that can represent all values ranging from @math{-10^I} (exclusive)
-to @math{10^I} (exclusive). If there is no integer kind that accommodates
+@code{SELECTED_INT_KIND(R)} return the kind value of the smallest integer
+type that can represent all values ranging from @math{-10^R} (exclusive)
+to @math{10^R} (exclusive). If there is no integer kind that accommodates
this range, @code{SELECTED_INT_KIND} returns @math{-1}.
@item @emph{Standard}:
@@ -9444,11 +9460,11 @@ Fortran 95 and later
Transformational function
@item @emph{Syntax}:
-@code{RESULT = SELECTED_INT_KIND(I)}
+@code{RESULT = SELECTED_INT_KIND(R)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{I} @tab Shall be a scalar and of type @code{INTEGER}.
+@item @var{R} @tab Shall be a scalar and of type @code{INTEGER}.
@end multitable
@item @emph{Example}:
@@ -9489,7 +9505,7 @@ Fortran 95 and later
Transformational function
@item @emph{Syntax}:
-@code{RESULT = SELECTED_REAL_KIND(P, R)}
+@code{RESULT = SELECTED_REAL_KIND([P, R])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@@ -10212,21 +10228,21 @@ This function returns information about a file. No permissions are required on
the file itself, but execute (search) permission is required on all of the
directories in path that lead to the file.
-The elements that are obtained and stored in the array @code{BUFF}:
+The elements that are obtained and stored in the array @code{VALUES}:
@multitable @columnfractions .15 .70
-@item @code{buff(1)} @tab Device ID
-@item @code{buff(2)} @tab Inode number
-@item @code{buff(3)} @tab File mode
-@item @code{buff(4)} @tab Number of links
-@item @code{buff(5)} @tab Owner's uid
-@item @code{buff(6)} @tab Owner's gid
-@item @code{buff(7)} @tab ID of device containing directory entry for file (0 if not available)
-@item @code{buff(8)} @tab File size (bytes)
-@item @code{buff(9)} @tab Last access time
-@item @code{buff(10)} @tab Last modification time
-@item @code{buff(11)} @tab Last file status change time
-@item @code{buff(12)} @tab Preferred I/O block size (-1 if not available)
-@item @code{buff(13)} @tab Number of blocks allocated (-1 if not available)
+@item @code{VALUES(1)} @tab Device ID
+@item @code{VALUES(2)} @tab Inode number
+@item @code{VALUES(3)} @tab File mode
+@item @code{VALUES(4)} @tab Number of links
+@item @code{VALUES(5)} @tab Owner's uid
+@item @code{VALUES(6)} @tab Owner's gid
+@item @code{VALUES(7)} @tab ID of device containing directory entry for file (0 if not available)
+@item @code{VALUES(8)} @tab File size (bytes)
+@item @code{VALUES(9)} @tab Last access time
+@item @code{VALUES(10)} @tab Last modification time
+@item @code{VALUES(11)} @tab Last file status change time
+@item @code{VALUES(12)} @tab Preferred I/O block size (-1 if not available)
+@item @code{VALUES(13)} @tab Number of blocks allocated (-1 if not available)
@end multitable
Not all these elements are relevant on all systems.
@@ -10242,13 +10258,13 @@ GNU extension
Subroutine, function
@item @emph{Syntax}:
-@code{CALL STAT(FILE,BUFF[,STATUS])}
+@code{CALL STAT(NAME, VALUES [, STATUS])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{FILE} @tab The type shall be @code{CHARACTER}, of the
+@item @var{NAME} @tab The type shall be @code{CHARACTER}, of the
default kind and a valid path within the file system.
-@item @var{BUFF} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
+@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}.
@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0
on success and a system specific error code otherwise.
@end multitable
@@ -10305,8 +10321,10 @@ Fortran 95 and later
Transformational function
@item @emph{Syntax}:
-@code{RESULT = SUM(ARRAY[, MASK])}
-@code{RESULT = SUM(ARRAY, DIM[, MASK])}
+@multitable @columnfractions .80
+@item @code{RESULT = SUM(ARRAY[, MASK])}
+@item @code{RESULT = SUM(ARRAY, DIM[, MASK])}
+@end multitable
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@@ -10965,22 +10983,24 @@ the relevant dimension.
@table @asis
@item @emph{Description}:
-Sets the file creation mask to @var{MASK} and returns the old value in
-argument @var{OLD} if it is supplied. See @code{umask(2)}.
+Sets the file creation mask to @var{MASK}. If called as a function, it
+returns the old value. If called as a subroutine and argument @var{OLD}
+if it is supplied, it is set to the old value. See @code{umask(2)}.
@item @emph{Standard}:
GNU extension
@item @emph{Class}:
-Subroutine
+Subroutine, function
@item @emph{Syntax}:
@code{CALL UMASK(MASK [, OLD])}
+@code{OLD = UMASK(MASK)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{MASK} @tab Shall be a scalar of type @code{INTEGER}.
-@item @var{MASK} @tab (Optional) Shall be a scalar of type
+@item @var{OLD} @tab (Optional) Shall be a scalar of type
@code{INTEGER}.
@end multitable
@@ -11154,13 +11174,13 @@ GNU extension
Function
@item @emph{Syntax}:
-@code{RESULT = XOR(X, Y)}
+@code{RESULT = XOR(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{X} @tab The type shall be either a scalar @code{INTEGER}
+@item @var{I} @tab The type shall be either a scalar @code{INTEGER}
type or a scalar @code{LOGICAL} type.
-@item @var{Y} @tab The type shall be the same as the type of @var{I}.
+@item @var{J} @tab The type shall be the same as the type of @var{I}.
@end multitable
@item @emph{Return value}:
diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def
index 98c3c982267..94c12fd09af 100644
--- a/gcc/fortran/iso-c-binding.def
+++ b/gcc/fortran/iso-c-binding.def
@@ -56,41 +56,44 @@ NAMED_INTCST (ISOCBINDING_LONG_LONG, "c_long_long", \
NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \
get_int_kind_from_node (intmax_type_node), GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \
- get_int_kind_from_node (ptr_type_node), GFC_STD_F2003)
+ get_int_kind_from_name (INTPTR_TYPE), GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \
gfc_index_integer_kind, GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \
get_int_kind_from_node (signed_char_type_node), GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", get_int_kind_from_width (8), \
- GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", get_int_kind_from_width (16), \
- GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", get_int_kind_from_width (32), \
- GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", get_int_kind_from_width (64), \
- GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", \
+ get_int_kind_from_name (INT8_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", \
+ get_int_kind_from_name (INT16_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", \
+ get_int_kind_from_name (INT32_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", \
+ get_int_kind_from_name (INT64_TYPE), GFC_STD_F2003)
/* GNU Extension. */
-NAMED_INTCST (ISOCBINDING_INT128_T, "c_int128_t", get_int_kind_from_width (128), \
- GFC_STD_GNU)
+NAMED_INTCST (ISOCBINDING_INT128_T, "c_int128_t", \
+ get_int_kind_from_width (128), GFC_STD_GNU)
NAMED_INTCST (ISOCBINDING_INT_LEAST8_T, "c_int_least8_t", \
- get_int_kind_from_minimal_width (8), GFC_STD_F2003)
+ get_int_kind_from_name (INT_LEAST8_TYPE), GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_INT_LEAST16_T, "c_int_least16_t", \
- get_int_kind_from_minimal_width (16), GFC_STD_F2003)
+ get_int_kind_from_name (INT_LEAST16_TYPE), GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_INT_LEAST32_T, "c_int_least32_t", \
- get_int_kind_from_minimal_width (32), GFC_STD_F2003)
+ get_int_kind_from_name (INT_LEAST32_TYPE), GFC_STD_F2003)
NAMED_INTCST (ISOCBINDING_INT_LEAST64_T, "c_int_least64_t", \
- get_int_kind_from_minimal_width (64), GFC_STD_F2003)
+ get_int_kind_from_name (INT_LEAST64_TYPE), GFC_STD_F2003)
/* GNU Extension. */
NAMED_INTCST (ISOCBINDING_INT_LEAST128_T, "c_int_least128_t", \
get_int_kind_from_minimal_width (128), GFC_STD_GNU)
-/* TODO: Implement c_int_fast*_t. Depends on PR 448. */
-NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", -2, GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", -2, GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", -2, GFC_STD_F2003)
-NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", -2, GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", \
+ get_int_kind_from_name (INT_FAST8_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", \
+ get_int_kind_from_name (INT_FAST16_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", \
+ get_int_kind_from_name (INT_FAST32_TYPE), GFC_STD_F2003)
+NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", \
+ get_int_kind_from_name (INT_FAST64_TYPE), GFC_STD_F2003)
/* GNU Extension. */
NAMED_INTCST (ISOCBINDING_INT_FAST128_T, "c_int_fast128_t", -2, GFC_STD_GNU)
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index 5f2c04231c5..fa6071f45b2 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -33,6 +33,14 @@ NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8, \
GFC_STD_F2003)
NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", GFC_STDIN_UNIT_NUMBER, \
GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_INT8, "int8", \
+ gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT16, "int16", \
+ gfc_get_int_kind_from_width_isofortranenv (16), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT32, "int32", \
+ gfc_get_int_kind_from_width_isofortranenv (32), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INT64, "int64", \
+ gfc_get_int_kind_from_width_isofortranenv (64), GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END, \
GFC_STD_F2003)
NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR, \
@@ -41,3 +49,9 @@ NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \
gfc_numeric_storage_size, GFC_STD_F2003)
NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER, \
GFC_STD_F2003)
+NAMED_INTCST (ISOFORTRANENV_REAL32, "real32", \
+ gfc_get_real_kind_from_width_isofortranenv (32), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \
+ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \
+ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008)
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 9da290c81fa..d29dddee8e1 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -350,7 +350,7 @@ Append a second underscore if the name already contains an underscore
fshort-enums
Fortran
-Use the narrowest integer type possible for enumeration types
+; Documented in C
fsign-zero
Fortran
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 136b751a196..94d61c9ec86 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -42,22 +42,15 @@ gfc_getmem (size_t n)
}
-/* gfortran.h defines free to something that triggers a syntax error,
- but we need free() here. */
-
-#define temp free
-#undef free
-
void
gfc_free (void *p)
{
+ /* The parentheses around free are needed in order to call not
+ the redefined free of gfortran.h. */
if (p != NULL)
- free (p);
+ (free) (p);
}
-#define free temp
-#undef temp
-
/* Get terminal width. */
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 2a48f88dbda..82a41996ca4 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -4759,7 +4759,7 @@ read_md5_from_module_file (const char * filename, unsigned char md5[16])
if ((file = fopen (filename, "r")) == NULL)
return -1;
- /* Read two lines. */
+ /* Read the first line. */
if (fgets (buf, sizeof (buf) - 1, file) == NULL)
{
fclose (file);
@@ -4769,8 +4769,12 @@ read_md5_from_module_file (const char * filename, unsigned char md5[16])
/* The file also needs to be overwritten if the version number changed. */
n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
- return -1;
+ {
+ fclose (file);
+ return -1;
+ }
+ /* Read a second line. */
if (fgets (buf, sizeof (buf) - 1, file) == NULL)
{
fclose (file);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 0e9dda80ce6..608d605c951 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1503,6 +1503,9 @@ resolve_omp_do (gfc_code *code)
void
gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
+ if (code->op != EXEC_OMP_ATOMIC)
+ gfc_maybe_initialize_eh ();
+
switch (code->op)
{
case EXEC_OMP_DO:
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 65841f6a629..2d899f546ab 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -137,7 +137,7 @@ gfc_init_options (unsigned int argc, const char **argv)
set_default_std_flags ();
/* -fshort-enums can be default on some targets. */
- gfc_option.fshort_enums = targetm.default_short_enums ();
+ flag_short_enums = targetm.default_short_enums ();
/* Initialize cpp-related options. */
gfc_cpp_init_options(argc, argv);
@@ -858,7 +858,7 @@ gfc_handle_option (size_t scode, const char *arg, int value)
break;
case OPT_fshort_enums:
- gfc_option.fshort_enums = 1;
+ flag_short_enums = 1;
break;
case OPT_fconvert_little_endian:
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 96fbddce92a..1a03165fcbe 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1726,7 +1726,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
tail = NULL;
gfc_gobble_whitespace ();
- if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension)
+ if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ || (sym->attr.dimension && !sym->attr.proc_pointer))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
@@ -1843,7 +1844,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
break;
}
- if (component->as != NULL)
+ if (component->as != NULL && !component->attr.proc_pointer)
{
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
@@ -2558,7 +2559,7 @@ gfc_match_rvalue (gfc_expr **result)
if (gfc_matching_procptr_assignment)
{
gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () == '(')
+ if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
/* Parse functions returning a procptr. */
goto function0;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index dbca1752b55..8158b71ee4f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3897,6 +3897,8 @@ resolve_array_ref (gfc_array_ref *ar)
static gfc_try
resolve_substring (gfc_ref *ref)
{
+ int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
if (ref->u.ss.start != NULL)
{
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
@@ -3954,6 +3956,16 @@ resolve_substring (gfc_ref *ref)
&ref->u.ss.start->where);
return FAILURE;
}
+
+ if (compare_bound_mpz_t (ref->u.ss.end,
+ gfc_integer_kinds[k].huge) == CMP_GT
+ && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
+ || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
+ {
+ gfc_error ("Substring end index at %L is too large",
+ &ref->u.ss.end->where);
+ return FAILURE;
+ }
}
return SUCCESS;
@@ -4016,7 +4028,7 @@ gfc_resolve_substring_charlen (gfc_expr *e)
e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
e->ts.cl->length->ts.type = BT_INTEGER;
- e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
/* Make sure that the length is simplified. */
gfc_simplify_expr (e->ts.cl->length, 1);
@@ -4475,7 +4487,7 @@ gfc_resolve_character_operator (gfc_expr *e)
e->ts.cl->length = gfc_add (e1, e2);
e->ts.cl->length->ts.type = BT_INTEGER;
- e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;
gfc_simplify_expr (e->ts.cl->length, 0);
gfc_resolve_expr (e->ts.cl->length);
@@ -4828,6 +4840,9 @@ resolve_ppc_call (gfc_code* c)
if (!comp->attr.subroutine)
gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
+ if (resolve_ref (c->expr1) == FAILURE)
+ return FAILURE;
+
if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
comp->formal == NULL) == FAILURE)
return FAILURE;
@@ -4853,10 +4868,15 @@ resolve_expr_ppc (gfc_expr* e)
e->value.function.isym = NULL;
e->value.function.actual = e->value.compcall.actual;
e->ts = comp->ts;
+ if (comp->as != NULL)
+ e->rank = comp->as->rank;
if (!comp->attr.function)
gfc_add_function (&comp->attr, comp->name, &e->where);
+ if (resolve_ref (e) == FAILURE)
+ return FAILURE;
+
if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
comp->formal == NULL) == FAILURE)
return FAILURE;
@@ -7383,7 +7403,7 @@ resolve_index_expr (gfc_expr *e)
static gfc_try
resolve_charlen (gfc_charlen *cl)
{
- int i;
+ int i, k;
if (cl->resolved)
return SUCCESS;
@@ -7407,6 +7427,16 @@ resolve_charlen (gfc_charlen *cl)
gfc_replace_expr (cl->length, gfc_int_expr (0));
}
+ /* Check that the character length is not too large. */
+ k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+ if (cl->length && cl->length->expr_type == EXPR_CONSTANT
+ && cl->length->ts.type == BT_INTEGER
+ && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
+ {
+ gfc_error ("String length at %L is too large", &cl->length->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
@@ -8563,7 +8593,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1))
+ if (gfc_compare_interfaces (sym1, sym2, 1, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
@@ -9125,7 +9155,8 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym != c->ts.derived)
add_dt_to_dt_list (c->ts.derived);
- if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
+ if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
+ || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
@@ -9385,6 +9416,7 @@ resolve_symbol (gfc_symbol *sym)
|| sym->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;
+ resolve_symbol (ifc);
if (ifc->attr.intrinsic)
resolve_intrinsic (ifc, &ifc->declared_at);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 7be4671acfb..01b252cf2ad 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1213,6 +1213,143 @@ gfc_simplify_erfc (gfc_expr *x)
}
+/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
+
+#define MAX_ITER 200
+#define ARG_LIMIT 12
+
+/* Calculate ERFC_SCALED directly by its definition:
+
+ ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
+
+ using a large precision for intermediate results. This is used for all
+ but large values of the argument. */
+static void
+fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+ mp_prec_t prec;
+ mpfr_t a, b;
+
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (10 * prec);
+
+ mpfr_init (a);
+ mpfr_init (b);
+
+ mpfr_set (a, arg, GFC_RND_MODE);
+ mpfr_sqr (b, a, GFC_RND_MODE);
+ mpfr_exp (b, b, GFC_RND_MODE);
+ mpfr_erfc (a, a, GFC_RND_MODE);
+ mpfr_mul (a, a, b, GFC_RND_MODE);
+
+ mpfr_set (res, a, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clear (a);
+ mpfr_clear (b);
+}
+
+/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
+
+ ERFC_SCALED(x) = 1 / (x * sqrt(pi))
+ * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
+ / (2 * x**2)**n)
+
+ This is used for large values of the argument. Intermediate calculations
+ are performed with twice the precision. We don't do a fixed number of
+ iterations of the sum, but stop when it has converged to the required
+ precision. */
+static void
+asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
+{
+ mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
+ mpz_t num;
+ mp_prec_t prec;
+ unsigned i;
+
+ prec = mpfr_get_default_prec ();
+ mpfr_set_default_prec (2 * prec);
+
+ mpfr_init (sum);
+ mpfr_init (x);
+ mpfr_init (u);
+ mpfr_init (v);
+ mpfr_init (w);
+ mpz_init (num);
+
+ mpfr_init (oldsum);
+ mpfr_init (sumtrunc);
+ mpfr_set_prec (oldsum, prec);
+ mpfr_set_prec (sumtrunc, prec);
+
+ mpfr_set (x, arg, GFC_RND_MODE);
+ mpfr_set_ui (sum, 1, GFC_RND_MODE);
+ mpz_set_ui (num, 1);
+
+ mpfr_set (u, x, GFC_RND_MODE);
+ mpfr_sqr (u, u, GFC_RND_MODE);
+ mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
+ mpfr_pow_si (u, u, -1, GFC_RND_MODE);
+
+ for (i = 1; i < MAX_ITER; i++)
+ {
+ mpfr_set (oldsum, sum, GFC_RND_MODE);
+
+ mpz_mul_ui (num, num, 2 * i - 1);
+ mpz_neg (num, num);
+
+ mpfr_set (w, u, GFC_RND_MODE);
+ mpfr_pow_ui (w, w, i, GFC_RND_MODE);
+
+ mpfr_set_z (v, num, GFC_RND_MODE);
+ mpfr_mul (v, v, w, GFC_RND_MODE);
+
+ mpfr_add (sum, sum, v, GFC_RND_MODE);
+
+ mpfr_set (sumtrunc, sum, GFC_RND_MODE);
+ if (mpfr_cmp (sumtrunc, oldsum) == 0)
+ break;
+ }
+
+ /* We should have converged by now; otherwise, ARG_LIMIT is probably
+ set too low. */
+ gcc_assert (i < MAX_ITER);
+
+ /* Divide by x * sqrt(Pi). */
+ mpfr_const_pi (u, GFC_RND_MODE);
+ mpfr_sqrt (u, u, GFC_RND_MODE);
+ mpfr_mul (u, u, x, GFC_RND_MODE);
+ mpfr_div (sum, sum, u, GFC_RND_MODE);
+
+ mpfr_set (res, sum, GFC_RND_MODE);
+ mpfr_set_default_prec (prec);
+
+ mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
+ mpz_clear (num);
+}
+
+
+gfc_expr *
+gfc_simplify_erfc_scaled (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
+ asympt_erfc_scaled (result->value.real, x->value.real);
+ else
+ fullprec_erfc_scaled (result->value.real, x->value.real);
+
+ return range_check (result, "ERFC_SCALED");
+}
+
+#undef MAX_ITER
+#undef ARG_LIMIT
+
+
gfc_expr *
gfc_simplify_epsilon (gfc_expr *e)
{
@@ -2433,7 +2570,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set_si (result->value.integer, e->value.character.length);
- return range_check (result, "LEN");
+ if (gfc_range_check (result) == ARITH_OK)
+ return result;
+ else
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
}
if (e->ts.cl != NULL && e->ts.cl->length != NULL
@@ -2442,7 +2585,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
result = gfc_constant_result (BT_INTEGER, k, &e->where);
mpz_set (result->value.integer, e->ts.cl->length->value.integer);
- return range_check (result, "LEN");
+ if (gfc_range_check (result) == ARITH_OK)
+ return result;
+ else
+ {
+ gfc_free_expr (result);
+ return NULL;
+ }
}
return NULL;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 81473a420bf..326d73e3ebf 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.intent = curr_arg->intent;
formal_arg->sym->attr.flavor = FL_VARIABLE;
formal_arg->sym->attr.dummy = 1;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index f4276ca133c..7dea22253f4 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3256,6 +3256,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
info->start[n]);
tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
info->stride[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, tmp);
tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
build_int_cst (gfc_array_index_type, 0));
/* We remember the size of the first section, and check all the
@@ -6293,6 +6295,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
gfc_ss *newss;
gfc_intrinsic_sym *isym;
gfc_symbol *sym;
+ gfc_component *comp = NULL;
isym = expr->value.function.isym;
@@ -6305,7 +6308,9 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
- if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
+ is_proc_ptr_comp (expr, &comp);
+ if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
+ || (comp && comp->attr.dimension))
{
newss = gfc_get_ss ();
newss->type = GFC_SS_FUNCTION;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cf17598c9f6..f1f009122ef 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
se->string_length = tmp;
}
- if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
- && c->ts.type != BT_CHARACTER)
+ if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+ || c->attr.proc_pointer)
se->expr = build_fold_indirect_ref (se->expr);
}
@@ -2396,6 +2396,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_symbol *fsym;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+ gfc_component *comp = NULL;
arglist = NULL_TREE;
retargs = NULL_TREE;
@@ -2550,11 +2551,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
+ is_proc_ptr_comp (expr, &comp);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length
&& sym->ts.cl->length->expr_type
!= EXPR_CONSTANT)
- || sym->attr.dimension);
+ || (comp && comp->attr.dimension)
+ || (!comp && sym->attr.dimension));
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
@@ -2825,7 +2828,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
- byref = gfc_return_by_reference (sym);
+ byref = (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
@@ -4053,6 +4057,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref (lse.expr);
+ if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+ && expr2->symtree->n.sym->attr.dummy)
+ rse.expr = build_fold_indirect_ref (rse.expr);
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
@@ -4284,6 +4292,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_ss *ss;
gfc_ref * ref;
bool seen_array_ref;
+ gfc_component *comp = NULL;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -4343,8 +4352,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
+ is_proc_ptr_comp(expr2, &comp);
gcc_assert (expr2->value.function.isym
- || (gfc_return_by_reference (expr2->value.function.esym)
+ || (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
@@ -4428,11 +4439,14 @@ gfc_trans_zero_assign (gfc_expr * expr)
len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
fold_convert (gfc_array_index_type, tmp));
- /* Convert arguments to the correct types. */
+ /* If we are zeroing a local array avoid taking its address by emitting
+ a = {} instead. */
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- dest = gfc_build_addr_expr (pvoid_type_node, dest);
- else
- dest = fold_convert (pvoid_type_node, dest);
+ return build2 (MODIFY_EXPR, void_type_node,
+ dest, build_constructor (TREE_TYPE (dest), NULL));
+
+ /* Convert arguments to the correct types. */
+ dest = fold_convert (pvoid_type_node, dest);
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memset. */
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index ae72e8d1b05..e945fcbf7b5 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -163,6 +163,96 @@ get_int_kind_from_node (tree type)
return -1;
}
+/* Return a typenode for the "standard" C type with a given name. */
+static tree
+get_typenode_from_name (const char *name)
+{
+ if (name == NULL || *name == '\0')
+ return NULL_TREE;
+
+ if (strcmp (name, "char") == 0)
+ return char_type_node;
+ if (strcmp (name, "unsigned char") == 0)
+ return unsigned_char_type_node;
+ if (strcmp (name, "signed char") == 0)
+ return signed_char_type_node;
+
+ if (strcmp (name, "short int") == 0)
+ return short_integer_type_node;
+ if (strcmp (name, "short unsigned int") == 0)
+ return short_unsigned_type_node;
+
+ if (strcmp (name, "int") == 0)
+ return integer_type_node;
+ if (strcmp (name, "unsigned int") == 0)
+ return unsigned_type_node;
+
+ if (strcmp (name, "long int") == 0)
+ return long_integer_type_node;
+ if (strcmp (name, "long unsigned int") == 0)
+ return long_unsigned_type_node;
+
+ if (strcmp (name, "long long int") == 0)
+ return long_long_integer_type_node;
+ if (strcmp (name, "long long unsigned int") == 0)
+ return long_long_unsigned_type_node;
+
+ gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+ return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+ following the required return values for ISO_FORTRAN_ENV INT* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size > size)
+ return -2;
+
+ return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+ following the required return values for ISO_FORTRAN_ENV REAL* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ size /= 8;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+ return gfc_real_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+ return -2;
+
+ return -1;
+}
+
+
+
static int
get_int_kind_from_width (int size)
{
@@ -680,6 +770,7 @@ gfc_build_logical_type (gfc_logical_info *info)
return new_type;
}
+
#if 0
/* Return the bit size of the C "size_t". */
@@ -1784,7 +1875,7 @@ tree
gfc_get_ppc_type (gfc_component* c)
{
tree t;
- if (c->attr.function)
+ if (c->attr.function && !c->attr.dimension)
t = gfc_typenode_for_spec (&c->ts);
else
t = void_type_node;
@@ -1906,7 +1997,7 @@ gfc_get_derived_type (gfc_symbol * derived)
/* This returns an array descriptor type. Initialization may be
required. */
- if (c->attr.dimension)
+ if (c->attr.dimension && !c->attr.proc_pointer)
{
if (c->attr.pointer || c->attr.allocatable)
{
View Lorry Controller Status