Skip to content

R
riscv-gcc-1
Commit b251af97 by Steven G. Kargl
Options

interface.c, [...]: Update Copyright years. 

2007-01-08  Steven G. Kargl  <kargl@gcc.gnu.org>

    * interface.c, intrinsic.c, gfortranspec.c, io.c, f95-lang.c,
    iresolve.c, match.c:  Update Copyright years.  Whitespace.

From-SVN: r120587
parent 7fb41a42
Showing with 1243 additions and 1353 deletions
gcc/fortran/ChangeLog
2007-01-08 Steven G. Kargl <kargl@gcc.gnu.org>
* interface.c, intrinsic.c, gfortranspec.c, io.c, f95-lang.c,
iresolve.c, match.c: Update Copyright years. Whitespace.
2007-01-08 Richard Guenther <rguenther@suse.de>
* trans-io.c (transfer_array_desc): Use build_int_cst instead
......
gcc/fortran/f95-lang.c
/* gfortran backend interface
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Paul Brook.
......@@ -238,7 +238,7 @@ gfc_expand_function (tree fndecl)
tree_rest_of_compilation (fndecl);
}
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
or validate its data type for an `if' or `while' statement or ?..: exp.
......@@ -267,8 +267,7 @@ gfc_truthvalue_conversion (tree expr)
return expr;
}
else if (TREE_CODE (expr) == NOP_EXPR)
return build1 (NOP_EXPR, boolean_type_node,
TREE_OPERAND (expr, 0));
return build1 (NOP_EXPR, boolean_type_node, TREE_OPERAND (expr, 0));
else
return build1 (NOP_EXPR, boolean_type_node, expr);
......@@ -284,6 +283,7 @@ gfc_truthvalue_conversion (tree expr)
}
}
static void
gfc_create_decls (void)
{
......@@ -296,6 +296,7 @@ gfc_create_decls (void)
gfc_init_constants ();
}
static void
gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
......@@ -314,7 +315,8 @@ gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
errorcount += errors;
warningcount += warnings;
}
/* Initialize everything. */
static bool
......@@ -353,15 +355,16 @@ gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
{
return;
}
/* These functions and variables deal with binding contours. We only
need these functions for the list of PARM_DECLs, but we leave the
functions more general; these are a simplified version of the
functions from GNAT. */
/* For each binding contour we allocate a binding_level structure which records
the entities defined or declared in that contour. Contours include:
/* For each binding contour we allocate a binding_level structure which
records the entities defined or declared in that contour. Contours
include:
the global one
one for each subprogram definition
......@@ -394,7 +397,8 @@ static GTY(()) struct binding_level *global_binding_level;
/* Binding level structures are initialized by copying this one. */
static struct binding_level clear_binding_level = { NULL, NULL, NULL };
/* Return nonzero if we are currently in the global binding level. */
int
......@@ -457,7 +461,7 @@ poplevel (int keep, int reverse, int functionbody)
reverse order except for PARM_DECL node, which are explicitly stored in
the right order. */
decl_chain = (reverse) ? nreverse (current_binding_level->names)
: current_binding_level->names;
: current_binding_level->names;
/* If there were any declarations in the current binding level, or if this
binding level is a function body, or if there are any nested blocks then
......@@ -515,7 +519,8 @@ poplevel (int keep, int reverse, int functionbody)
return block_node;
}
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
to handle the BLOCK node inside the BIND_EXPR. */
......@@ -528,6 +533,7 @@ insert_block (tree block)
= chainon (current_binding_level->blocks, block);
}
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
......@@ -625,6 +631,7 @@ gfc_init_decl_processing (void)
gfc_init_types ();
}
/* Mark EXP saying that we need to be able to take the
address of it; it should not be allocated in a register.
In Fortran 95 this is only the case for variables with
......@@ -632,6 +639,7 @@ gfc_init_decl_processing (void)
likely future Cray pointer extension.
Value is 1 if successful. */
/* TODO: Check/fix mark_addressable. */
bool
gfc_mark_addressable (tree exp)
{
......@@ -659,9 +667,8 @@ gfc_mark_addressable (tree exp)
{
if (TREE_PUBLIC (x))
{
error
("global register variable %qs used in nested function",
IDENTIFIER_POINTER (DECL_NAME (x)));
error ("global register variable %qs used in nested function",
IDENTIFIER_POINTER (DECL_NAME (x)));
return false;
}
pedwarn ("register variable %qs used in nested function",
......@@ -702,6 +709,7 @@ gfc_mark_addressable (tree exp)
}
}
/* Return the typed-based alias set for T, which may be an expression
or a type. Return -1 if we don't do anything special. */
......@@ -720,6 +728,7 @@ gfc_get_alias_set (tree t)
return -1;
}
/* press the big red button - garbage (ggc) collection is on */
int ggc_p = 1;
......@@ -736,10 +745,10 @@ gfc_builtin_function (tree decl)
static void
gfc_define_builtin (const char * name,
gfc_define_builtin (const char *name,
tree type,
int code,
const char * library_name,
const char *library_name,
bool const_p)
{
tree decl;
......@@ -773,7 +782,7 @@ gfc_define_builtin (const char * name,
/* Create function types for builtin functions. */
static void
build_builtin_fntypes (tree * fntype, tree type)
build_builtin_fntypes (tree *fntype, tree type)
{
tree tmp;
......@@ -789,6 +798,7 @@ build_builtin_fntypes (tree * fntype, tree type)
fntype[2] = build_function_type (type, tmp);
}
static tree
builtin_type_for_size (int size, bool unsignedp)
{
......
gcc/fortran/gfortranspec.c
/* Specific flags and argument handling of the Fortran front-end.
Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
This file is part of GCC.
......@@ -18,6 +18,7 @@ You should have received a copy of the GNU General Public License
along with GNU CC; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
/* This file is copied more or less verbatim from g77. */
/* This file contains a filter for the main `gcc' driver, which is
replicated for the `gfortran' driver by adding this filter. The purpose
......@@ -160,7 +161,7 @@ lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text)
opt = OPTION_x, arg = text + 2;
else
{
if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */
if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */
;
else if (!strcmp (text, "-fhelp")) /* Really --help!! */
opt = OPTION_help;
......@@ -346,7 +347,7 @@ lang_specific_driver (int *in_argc, const char *const **in_argv,
case OPTION_version:
printf ("GNU Fortran 95 (GCC) %s\n", version_string);
printf ("Copyright %s 2006 Free Software Foundation, Inc.\n\n",
_("(C)"));
_("(C)"));
printf (_("GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\
You may redistribute copies of GNU Fortran\n\
under the terms of the GNU General Public License.\n\
......@@ -364,7 +365,7 @@ For more information about these matters, see the file named COPYING\n\n"));
}
/* This is the one place we check for missing arguments in the
program. */
program. */
if (i + skip < argc)
i += skip;
......@@ -392,25 +393,25 @@ For more information about these matters, see the file named COPYING\n\n"));
}
if ((argv[i][0] == '-') && (argv[i][1] == 'M'))
{
char *p;
if (argv[i][2] == '\0')
{
p = XNEWVEC (char, strlen (argv[i + 1]) + 2);
p[0] = '-';
p[1] = 'J';
strcpy (&p[2], argv[i + 1]);
i++;
}
else
{
p = XNEWVEC (char, strlen (argv[i]) + 1);
strcpy (p, argv[i]);
}
append_arg (p);
continue;
}
{
char *p;
if (argv[i][2] == '\0')
{
p = XNEWVEC (char, strlen (argv[i + 1]) + 2);
p[0] = '-';
p[1] = 'J';
strcpy (&p[2], argv[i + 1]);
i++;
}
else
{
p = XNEWVEC (char, strlen (argv[i]) + 1);
strcpy (p, argv[i]);
}
append_arg (p);
continue;
}
if ((argv[i][0] == '-') && (argv[i][1] != 'l'))
{
......@@ -535,6 +536,7 @@ For more information about these matters, see the file named COPYING\n\n"));
*in_argv = g77_newargv;
}
/* Called before linking. Returns 0 on success and -1 on failure. */
int
lang_specific_pre_link (void) /* Not used for F77. */
......
gcc/fortran/interface.c
/* Deal with interfaces.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
......@@ -70,7 +70,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "gfortran.h"
#include "match.h"
/* The current_interface structure holds information about the
interface currently being parsed. This structure is saved and
restored during recursive interfaces. */
......@@ -81,7 +80,7 @@ gfc_interface_info current_interface;
/* Free a singly linked list of gfc_interface structures. */
void
gfc_free_interface (gfc_interface * intr)
gfc_free_interface (gfc_interface *intr)
{
gfc_interface *next;
......@@ -99,7 +98,6 @@ gfc_free_interface (gfc_interface * intr)
static gfc_intrinsic_op
fold_unary (gfc_intrinsic_op operator)
{
switch (operator)
{
case INTRINSIC_UPLUS:
......@@ -121,7 +119,7 @@ fold_unary (gfc_intrinsic_op operator)
This subroutine doesn't return MATCH_NO. */
match
gfc_match_generic_spec (interface_type * type,
gfc_match_generic_spec (interface_type *type,
char *name,
gfc_intrinsic_op *operator)
{
......@@ -194,15 +192,13 @@ gfc_match_interface (void)
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
return MATCH_ERROR;
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
|| (type != INTERFACE_NAMELESS
&& m != MATCH_YES))
|| (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
gfc_error
("Syntax error: Trailing garbage in INTERFACE statement at %C");
gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
"at %C");
return MATCH_ERROR;
}
......@@ -263,11 +259,10 @@ gfc_match_end_interface (void)
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
|| (type != INTERFACE_NAMELESS
&& m != MATCH_YES))
|| (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
gfc_error
("Syntax error: Trailing garbage in END INTERFACE statement at %C");
gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
"statement at %C");
return MATCH_ERROR;
}
......@@ -301,7 +296,7 @@ gfc_match_end_interface (void)
case INTERFACE_USER_OP:
/* Comparing the symbol node names is OK because only use-associated
symbols can be renamed. */
symbols can be renamed. */
if (type != current_interface.type
|| strcmp (current_interface.uop->name, name) != 0)
{
......@@ -332,7 +327,7 @@ gfc_match_end_interface (void)
recursing through gfc_compare_types for the components. */
int
gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
{
gfc_component *dt1, *dt2;
......@@ -340,9 +335,9 @@ gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
true names and module names are the same and the module name is
nonnull, then they are equal. */
if (strcmp (derived1->name, derived2->name) == 0
&& derived1 != NULL && derived2 != NULL
&& derived1->module != NULL && derived2->module != NULL
&& strcmp (derived1->module, derived2->module) == 0)
&& derived1 != NULL && derived2 != NULL
&& derived1->module != NULL && derived2->module != NULL
&& strcmp (derived1->module, derived2->module) == 0)
return 1;
/* Compare type via the rules of the standard. Both types must have
......@@ -352,7 +347,7 @@ gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
return 0;
if (derived1->component_access == ACCESS_PRIVATE
|| derived2->component_access == ACCESS_PRIVATE)
|| derived2->component_access == ACCESS_PRIVATE)
return 0;
if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
......@@ -396,12 +391,12 @@ gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
return 1;
}
/* Compare two typespecs, recursively if necessary. */
int
gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
if (ts1->type != ts2->type)
return 0;
if (ts1->type != BT_DERIVED)
......@@ -420,7 +415,7 @@ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
zero otherwise. */
static int
compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
{
int r1, r2;
......@@ -441,7 +436,7 @@ static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
procedures. Returns nonzero if the same, zero if different. */
static int
compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? 1 : 0;
......@@ -475,9 +470,8 @@ compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
if not found. */
static gfc_symbol *
find_keyword_arg (const char *name, gfc_formal_arglist * f)
find_keyword_arg (const char *name, gfc_formal_arglist *f)
{
for (; f; f = f->next)
if (strcmp (f->sym->name, name) == 0)
return f->sym;
......@@ -493,7 +487,7 @@ find_keyword_arg (const char *name, gfc_formal_arglist * f)
interfaces for that operator are legal. */
static void
check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
{
gfc_formal_arglist *formal;
sym_intent i1, i2;
......@@ -539,27 +533,24 @@ check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
{
if (!sym->attr.subroutine)
{
gfc_error
("Assignment operator interface at %L must be a SUBROUTINE",
&intr->where);
gfc_error ("Assignment operator interface at %L must be "
"a SUBROUTINE", &intr->where);
return;
}
if (args != 2)
{
gfc_error
("Assignment operator interface at %L must have two arguments",
&intr->where);
gfc_error ("Assignment operator interface at %L must have "
"two arguments", &intr->where);
return;
}
if (sym->formal->sym->ts.type != BT_DERIVED
&& sym->formal->next->sym->ts.type != BT_DERIVED
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
|| (gfc_numeric_ts (&sym->formal->sym->ts)
&& gfc_numeric_ts (&sym->formal->next->sym->ts))))
&& sym->formal->next->sym->ts.type != BT_DERIVED
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
|| (gfc_numeric_ts (&sym->formal->sym->ts)
&& gfc_numeric_ts (&sym->formal->next->sym->ts))))
{
gfc_error
("Assignment operator interface at %L must not redefine "
"an INTRINSIC type assignment", &intr->where);
gfc_error ("Assignment operator interface at %L must not redefine "
"an INTRINSIC type assignment", &intr->where);
return;
}
}
......@@ -578,9 +569,7 @@ check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
case INTRINSIC_PLUS: /* Numeric unary or binary */
case INTRINSIC_MINUS:
if ((args == 1)
&& (t1 == BT_INTEGER
|| t1 == BT_REAL
|| t1 == BT_COMPLEX))
&& (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX))
goto bad_repl;
if ((args == 2)
......@@ -696,7 +685,7 @@ num_args:
14.1.2.3. */
static int
count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
int rc, ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
......@@ -762,7 +751,7 @@ count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
ac1++;
/* Count the number of arguments in f2 with that type, including
those that are optional. */
those that are optional. */
ac2 = 0;
for (f = f2; f; f = f->next)
......@@ -794,7 +783,7 @@ count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
which is what happens here. */
static int
operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
for (;;)
{
......@@ -824,20 +813,19 @@ operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
INTERFACE FOO
SUBROUTINE F1(A, B)
INTEGER :: A ; REAL :: B
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F2(B, A)
INTEGER :: A ; REAL :: B
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
END INTERFACE FOO
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
static int
generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
gfc_formal_arglist *f2_save, *g;
gfc_symbol *sym;
......@@ -852,7 +840,7 @@ generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
goto next;
/* Now search for a disambiguating keyword argument starting at
the current non-match. */
the current non-match. */
for (g = f1; g; g = g->next)
{
if (g->sym->attr.optional)
......@@ -878,7 +866,7 @@ generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
would be ambiguous between the two interfaces, zero otherwise. */
static int
compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
{
gfc_formal_arglist *f1, *f2;
......@@ -919,7 +907,7 @@ compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
subroutines. Returns nonzero if something goes wrong. */
static int
check_interface0 (gfc_interface * p, const char *interface_name)
check_interface0 (gfc_interface *p, const char *interface_name)
{
gfc_interface *psave, *q, *qlast;
......@@ -947,7 +935,6 @@ check_interface0 (gfc_interface * p, const char *interface_name)
{
qlast = q;
q = q->next;
}
else
{
......@@ -968,11 +955,11 @@ check_interface0 (gfc_interface * p, const char *interface_name)
here. */
static int
check_interface1 (gfc_interface * p, gfc_interface * q0,
check_interface1 (gfc_interface *p, gfc_interface *q0,
int generic_flag, const char *interface_name,
bool referenced)
{
gfc_interface * q;
gfc_interface *q;
for (; p; p = p->next)
for (q = q0; q; q = q->next)
{
......@@ -1007,7 +994,7 @@ check_interface1 (gfc_interface * p, gfc_interface * q0,
after all of the symbols are actually loaded. */
static void
check_sym_interfaces (gfc_symbol * sym)
check_sym_interfaces (gfc_symbol *sym)
{
char interface_name[100];
bool k;
......@@ -1024,9 +1011,8 @@ check_sym_interfaces (gfc_symbol * sym)
for (p = sym->generic; p; p = p->next)
{
if (!p->sym->attr.use_assoc
&& p->sym->attr.mod_proc
&& p->sym->attr.if_source != IFSRC_DECL)
if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
&& p->sym->attr.if_source != IFSRC_DECL)
{
gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
"from a module", p->sym->name, &p->where);
......@@ -1038,15 +1024,14 @@ check_sym_interfaces (gfc_symbol * sym)
this is incorrect since host associated symbols, from any
source, cannot be ambiguous with local symbols. */
k = sym->attr.referenced || !sym->attr.use_assoc;
if (check_interface1 (sym->generic, sym->generic, 1,
interface_name, k))
if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
sym->attr.ambiguous_interfaces = 1;
}
}
static void
check_uop_interfaces (gfc_user_op * uop)
check_uop_interfaces (gfc_user_op *uop)
{
char interface_name[100];
gfc_user_op *uop2;
......@@ -1074,7 +1059,7 @@ check_uop_interfaces (gfc_user_op * uop)
that most symbols will not have generic or operator interfaces. */
void
gfc_check_interfaces (gfc_namespace * ns)
gfc_check_interfaces (gfc_namespace *ns)
{
gfc_namespace *old_ns, *ns2;
char interface_name[100];
......@@ -1114,9 +1099,8 @@ gfc_check_interfaces (gfc_namespace * ns)
static int
symbol_rank (gfc_symbol * sym)
symbol_rank (gfc_symbol *sym)
{
return (sym->as == NULL) ? 0 : sym->as->rank;
}
......@@ -1126,7 +1110,7 @@ symbol_rank (gfc_symbol * sym)
allocatable. Returns nonzero if compatible, zero if not compatible. */
static int
compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
......@@ -1146,7 +1130,7 @@ compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
pointer. Returns nonzero if compatible, zero if not compatible. */
static int
compare_pointer (gfc_symbol * formal, gfc_expr * actual)
compare_pointer (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
......@@ -1166,7 +1150,7 @@ compare_pointer (gfc_symbol * formal, gfc_expr * actual)
compatible, zero if not compatible. */
static int
compare_parameter (gfc_symbol * formal, gfc_expr * actual,
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
int ranks_must_agree, int is_elemental)
{
gfc_ref *ref;
......@@ -1181,7 +1165,7 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual,
return 0;
if (formal->attr.if_source == IFSRC_UNKNOWN
|| actual->symtree->n.sym->attr.external)
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match */
return compare_interfaces (formal, actual->symtree->n.sym, 0);
......@@ -1226,7 +1210,7 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual,
compatible, zero if not compatible. */
static int
compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
{
if (actual->expr_type != EXPR_VARIABLE)
return 1;
......@@ -1259,9 +1243,8 @@ compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
code. */
static int
compare_actual_formal (gfc_actual_arglist ** ap,
gfc_formal_arglist * formal,
int ranks_must_agree, int is_elemental, locus * where)
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where)
{
gfc_actual_arglist **new, *a, *actual, temp;
gfc_formal_arglist *f;
......@@ -1303,18 +1286,17 @@ compare_actual_formal (gfc_actual_arglist ** ap,
if (f == NULL)
{
if (where)
gfc_error
("Keyword argument '%s' at %L is not in the procedure",
a->name, &a->expr->where);
gfc_error ("Keyword argument '%s' at %L is not in "
"the procedure", a->name, &a->expr->where);
return 0;
}
if (new[i] != NULL)
{
if (where)
gfc_error
("Keyword argument '%s' at %L is already associated "
"with another actual argument", a->name, &a->expr->where);
gfc_error ("Keyword argument '%s' at %L is already associated "
"with another actual argument", a->name,
&a->expr->where);
return 0;
}
}
......@@ -1322,9 +1304,8 @@ compare_actual_formal (gfc_actual_arglist ** ap,
if (f == NULL)
{
if (where)
gfc_error
("More actual than formal arguments in procedure call at %L",
where);
gfc_error ("More actual than formal arguments in procedure "
"call at %L", where);
return 0;
}
......@@ -1335,29 +1316,25 @@ compare_actual_formal (gfc_actual_arglist ** ap,
if (f->sym == NULL)
{
if (where)
gfc_error
("Missing alternate return spec in subroutine call at %L",
where);
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
return 0;
}
if (a->expr == NULL)
{
if (where)
gfc_error
("Unexpected alternate return spec in subroutine call at %L",
where);
gfc_error ("Unexpected alternate return spec in subroutine "
"call at %L", where);
return 0;
}
rank_check = where != NULL
&& !is_elemental
&& f->sym->as
&& (f->sym->as->type == AS_ASSUMED_SHAPE
|| f->sym->as->type == AS_DEFERRED);
rank_check = where != NULL && !is_elemental && f->sym->as
&& (f->sym->as->type == AS_ASSUMED_SHAPE
|| f->sym->as->type == AS_DEFERRED);
if (!compare_parameter
(f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
if (!compare_parameter (f->sym, a->expr,
ranks_must_agree || rank_check, is_elemental))
{
if (where)
gfc_error ("Type/rank mismatch in argument '%s' at %L",
......@@ -1377,10 +1354,9 @@ compare_actual_formal (gfc_actual_arglist ** ap,
return 0;
}
if (f->sym->attr.flavor == FL_PROCEDURE
&& f->sym->attr.pure
&& a->expr->ts.type == BT_PROCEDURE
&& !a->expr->symtree->n.sym->attr.pure)
if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
&& a->expr->ts.type == BT_PROCEDURE
&& !a->expr->symtree->n.sym->attr.pure)
{
if (where)
gfc_error ("Expected a PURE procedure for argument '%s' at %L",
......@@ -1388,8 +1364,7 @@ compare_actual_formal (gfc_actual_arglist ** ap,
return 0;
}
if (f->sym->as
&& f->sym->as->type == AS_ASSUMED_SHAPE
if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym->as
&& a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
......@@ -1423,14 +1398,14 @@ compare_actual_formal (gfc_actual_arglist ** ap,
/* Check intent = OUT/INOUT for definable actual argument. */
if (a->expr->expr_type != EXPR_VARIABLE
&& (f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT))
&& (f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT))
{
if (where)
gfc_error ("Actual argument at %L must be definable to "
"match dummy INTENT = OUT/INOUT", &a->expr->where);
return 0;
}
return 0;
}
if (!compare_parameter_protected(f->sym, a->expr))
{
......@@ -1439,7 +1414,7 @@ compare_actual_formal (gfc_actual_arglist ** ap,
"PROTECTED attribute and dummy argument '%s' is "
"INTENT = OUT/INOUT",
&a->expr->where,f->sym->name);
return 0;
return 0;
}
match:
......@@ -1458,8 +1433,8 @@ compare_actual_formal (gfc_actual_arglist ** ap,
if (f->sym == NULL)
{
if (where)
gfc_error ("Missing alternate return spec in subroutine call at %L",
where);
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
return 0;
}
if (!f->sym->attr.optional)
......@@ -1552,7 +1527,7 @@ pair_cmp (const void *p1, const void *p2)
Returning FAILURE will produce no warning. */
static try
compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
......@@ -1595,12 +1570,13 @@ compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
return FAILURE;
}
/* Given formal and actual argument lists that correspond to one
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
static try
check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
gfc_formal_arglist *f1;
......@@ -1668,17 +1644,15 @@ check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
return non-zero if their intents are compatible, zero otherwise. */
static int
compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
{
if (actual->symtree->n.sym->attr.pointer
&& !formal->attr.pointer)
if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
return 1;
if (actual->symtree->n.sym->attr.intent != INTENT_IN)
return 1;
if (formal->attr.intent == INTENT_INOUT
|| formal->attr.intent == INTENT_OUT)
if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
return 0;
return 1;
......@@ -1690,7 +1664,7 @@ compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
are not mismatched. */
static try
check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f_intent;
......@@ -1708,7 +1682,6 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
if (!compare_parameter_intent(f->sym, a->expr))
{
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
"specifies INTENT(%s)", &a->expr->where,
gfc_intent_string (f_intent));
......@@ -1719,18 +1692,17 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
{
if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
{
gfc_error
("Procedure argument at %L is local to a PURE procedure and "
"is passed to an INTENT(%s) argument", &a->expr->where,
gfc_intent_string (f_intent));
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and is passed to an INTENT(%s) argument",
&a->expr->where, gfc_intent_string (f_intent));
return FAILURE;
}
if (a->expr->symtree->n.sym->attr.pointer)
{
gfc_error
("Procedure argument at %L is local to a PURE procedure and "
"has the POINTER attribute", &a->expr->where);
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
&a->expr->where);
return FAILURE;
}
}
......@@ -1745,14 +1717,14 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
sorted. */
void
gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
/* Warn about calls with an implicit interface. */
if (gfc_option.warn_implicit_interface
&& sym->attr.if_source == IFSRC_UNKNOWN)
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
sym->name, where);
sym->name, where);
if (sym->attr.if_source == IFSRC_UNKNOWN
|| !compare_actual_formal (ap, sym->formal, 0,
......@@ -1771,8 +1743,8 @@ gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
not found. */
gfc_symbol *
gfc_search_interface (gfc_interface * intr, int sub_flag,
gfc_actual_arglist ** ap)
gfc_search_interface (gfc_interface *intr, int sub_flag,
gfc_actual_arglist **ap)
{
int r;
......@@ -1801,7 +1773,7 @@ gfc_search_interface (gfc_interface * intr, int sub_flag,
/* Do a brute force recursive search for a symbol. */
static gfc_symtree *
find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
{
gfc_symtree * st;
......@@ -1820,7 +1792,7 @@ find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
/* Find a symtree for a symbol. */
static gfc_symtree *
find_sym_in_symtree (gfc_symbol * sym)
find_sym_in_symtree (gfc_symbol *sym)
{
gfc_symtree *st;
gfc_namespace *ns;
......@@ -1837,7 +1809,7 @@ find_sym_in_symtree (gfc_symbol * sym)
{
st = find_symtree0 (ns->sym_root, sym);
if (st)
return st;
return st;
}
gfc_internal_error ("Unable to find symbol %s", sym->name);
/* Not reached */
......@@ -1853,7 +1825,7 @@ find_sym_in_symtree (gfc_symbol * sym)
the appropriate function call. */
try
gfc_extend_expr (gfc_expr * e)
gfc_extend_expr (gfc_expr *e)
{
gfc_actual_arglist *actual;
gfc_symbol *sym;
......@@ -1917,9 +1889,8 @@ gfc_extend_expr (gfc_expr * e)
if (gfc_pure (NULL) && !gfc_pure (sym))
{
gfc_error
("Function '%s' called in lieu of an operator at %L must be PURE",
sym->name, &e->where);
gfc_error ("Function '%s' called in lieu of an operator at %L must "
"be PURE", sym->name, &e->where);
return FAILURE;
}
......@@ -1936,7 +1907,7 @@ gfc_extend_expr (gfc_expr * e)
generated. */
try
gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
......@@ -1948,8 +1919,7 @@ gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
/* Don't allow an intrinsic assignment to be replaced. */
if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts)
&& gfc_numeric_ts (&rhs->ts))))
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
actual = gfc_get_actual_arglist ();
......@@ -2011,7 +1981,7 @@ check_new_interface (gfc_interface * base, gfc_symbol * new)
/* Add a symbol to the current interface. */
try
gfc_add_interface (gfc_symbol * new)
gfc_add_interface (gfc_symbol *new)
{
gfc_interface **head, *intr;
gfc_namespace *ns;
......@@ -2046,8 +2016,8 @@ gfc_add_interface (gfc_symbol * new)
break;
case INTERFACE_USER_OP:
if (check_new_interface (current_interface.uop->operator, new) ==
FAILURE)
if (check_new_interface (current_interface.uop->operator, new)
== FAILURE)
return FAILURE;
head = &current_interface.uop->operator;
......@@ -2072,7 +2042,7 @@ gfc_add_interface (gfc_symbol * new)
Symbols are freed when a namespace is freed. */
void
gfc_free_formal_arglist (gfc_formal_arglist * p)
gfc_free_formal_arglist (gfc_formal_arglist *p)
{
gfc_formal_arglist *q;
......
gcc/fortran/intrinsic.c
/* Build up a list of intrinsic subroutines and functions for the
name-resolution stage.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
......@@ -21,14 +21,12 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
/* Namespace to hold the resolved symbols for intrinsic subroutines. */
static gfc_namespace *gfc_intrinsic_namespace;
......@@ -59,6 +57,7 @@ sizing;
#define REQUIRED 0
#define OPTIONAL 1
/* Return a letter based on the passed type. Used to construct the
name of a type-dependent subroutine. */
......@@ -101,7 +100,7 @@ gfc_type_letter (bt type)
/* Get a symbol for a resolved name. */
gfc_symbol *
gfc_get_intrinsic_sub_symbol (const char * name)
gfc_get_intrinsic_sub_symbol (const char *name)
{
gfc_symbol *sym;
......@@ -119,7 +118,7 @@ gfc_get_intrinsic_sub_symbol (const char * name)
typespecs. */
static const char *
conv_name (gfc_typespec * from, gfc_typespec * to)
conv_name (gfc_typespec *from, gfc_typespec *to)
{
static char name[30];
......@@ -135,7 +134,7 @@ conv_name (gfc_typespec * from, gfc_typespec * to)
isn't found. */
static gfc_intrinsic_sym *
find_conv (gfc_typespec * from, gfc_typespec * to)
find_conv (gfc_typespec *from, gfc_typespec *to)
{
gfc_intrinsic_sym *sym;
const char *target;
......@@ -157,7 +156,7 @@ find_conv (gfc_typespec * from, gfc_typespec * to)
function to manipulate the argument list. */
static try
do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
......@@ -199,18 +198,18 @@ do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
Argument list:
char * name of function
int whether function is elemental
int If the function can be used as an actual argument [1]
bt return type of function
int kind of return type of function
int Fortran standard version
int whether function is elemental
int If the function can be used as an actual argument [1]
bt return type of function
int kind of return type of function
int Fortran standard version
check pointer to check function
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
bt type of argument
int kind of argument
int arg optional flag (1=optional, 0=required)
......@@ -316,10 +315,10 @@ add_sym (const char *name, int elemental, int actual_ok, bt type, int kind,
static void
add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(void),
gfc_expr *(*simplify)(void),
void (*resolve)(gfc_expr *))
int kind, int standard,
try (*check) (void),
gfc_expr *(*simplify) (void),
void (*resolve) (gfc_expr *))
{
gfc_simplify_f sf;
gfc_check_f cf;
......@@ -330,7 +329,7 @@ add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
rf.f0 = resolve;
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
(void*)0);
(void *) 0);
}
......@@ -338,8 +337,7 @@ add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
0 arguments. */
static void
add_sym_0s (const char * name, int standard,
void (*resolve)(gfc_code *))
add_sym_0s (const char *name, int standard, void (*resolve) (gfc_code *))
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -350,7 +348,7 @@ add_sym_0s (const char * name, int standard,
rf.s1 = resolve;
add_sym (name, ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, rf,
(void*)0);
(void *) 0);
}
......@@ -360,10 +358,10 @@ add_sym_0s (const char * name, int standard,
static void
add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(gfc_expr *),
gfc_expr *(*simplify)(gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *),
const char* a1, bt type1, int kind1, int optional1)
try (*check) (gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -375,7 +373,7 @@ add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
(void*)0);
(void *) 0);
}
......@@ -383,12 +381,11 @@ add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
1 arguments. */
static void
add_sym_1s (const char *name, int elemental, bt type,
int kind, int standard,
try (*check)(gfc_expr *),
gfc_expr *(*simplify)(gfc_expr *),
void (*resolve)(gfc_code *),
const char* a1, bt type1, int kind1, int optional1)
add_sym_1s (const char *name, int elemental, bt type, int kind, int standard,
try (*check) (gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -400,7 +397,7 @@ add_sym_1s (const char *name, int elemental, bt type,
add_sym (name, elemental, ACTUAL_NO, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
(void*)0);
(void *) 0);
}
......@@ -409,12 +406,12 @@ add_sym_1s (const char *name, int elemental, bt type,
static void
add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(gfc_actual_arglist *),
gfc_expr *(*simplify)(gfc_expr *),
void (*resolve)(gfc_expr *,gfc_actual_arglist *),
const char* a1, bt type1, int kind1, int optional1,
const char* a2, bt type2, int kind2, int optional2)
int kind, int standard,
try (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_expr *, gfc_actual_arglist *),
const char *a1, bt type1, int kind1, int optional1,
const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -427,7 +424,7 @@ add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
(void*)0);
(void *) 0);
}
......@@ -436,12 +433,12 @@ add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
static void
add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(gfc_expr *,gfc_expr *),
gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *),
const char* a1, bt type1, int kind1, int optional1,
const char* a2, bt type2, int kind2, int optional2)
int kind, int standard,
try (*check) (gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -454,7 +451,7 @@ add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
(void*)0);
(void *) 0);
}
......@@ -462,13 +459,12 @@ add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
2 arguments. */
static void
add_sym_2s (const char *name, int elemental, bt type,
int kind, int standard,
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,
const char* a2, bt type2, int kind2, int optional2)
add_sym_2s (const char *name, int elemental, bt type, int kind, int standard,
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,
const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -481,7 +477,7 @@ add_sym_2s (const char *name, int elemental, bt type,
add_sym (name, elemental, ACTUAL_NO, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
(void*)0);
(void *) 0);
}
......@@ -490,13 +486,13 @@ add_sym_2s (const char *name, int elemental, bt type,
static void
add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
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)
int kind, int standard,
try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
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)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -510,7 +506,7 @@ add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
(void*)0);
(void *) 0);
}
......@@ -518,14 +514,14 @@ add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
might have to be reordered. */
static void
add_sym_3ml (const char *name, int elemental,
int actual_ok, bt type, int kind, int standard,
try (*check)(gfc_actual_arglist *),
gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
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)
add_sym_3ml (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
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)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -539,7 +535,7 @@ add_sym_3ml (const char *name, int elemental,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
(void*)0);
(void *) 0);
}
......@@ -547,14 +543,14 @@ add_sym_3ml (const char *name, int elemental,
their argument also might have to be reordered. */
static void
add_sym_3red (const char *name, int elemental,
int actual_ok, bt type, int kind, int standard,
try (*check)(gfc_actual_arglist *),
gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
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)
add_sym_3red (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
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)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -568,7 +564,7 @@ add_sym_3red (const char *name, int elemental,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
(void*)0);
(void *) 0);
}
......@@ -576,14 +572,13 @@ add_sym_3red (const char *name, int elemental,
3 arguments. */
static void
add_sym_3s (const char *name, int elemental, bt type,
int kind, int standard,
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,
const char* a2, bt type2, int kind2, int optional2,
const char* a3, bt type3, int kind3, int optional3)
add_sym_3s (const char *name, int elemental, bt type, int kind, int standard,
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,
const char *a2, bt type2, int kind2, int optional2,
const char *a3, bt type3, int kind3, int optional3)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -597,7 +592,7 @@ add_sym_3s (const char *name, int elemental, bt type,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
(void*)0);
(void *) 0);
}
......@@ -606,14 +601,16 @@ add_sym_3s (const char *name, int elemental, bt type,
static void
add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
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 )
int kind, int standard,
try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
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 )
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -628,7 +625,7 @@ add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
(void*)0);
(void *) 0);
}
......@@ -636,15 +633,15 @@ add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
4 arguments. */
static void
add_sym_4s (const char *name, int elemental,
bt type, int kind, int standard,
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)
add_sym_4s (const char *name, int elemental, bt type, int kind, int standard,
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)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -659,7 +656,7 @@ add_sym_4s (const char *name, int elemental,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
(void*)0);
(void *) 0);
}
......@@ -667,16 +664,17 @@ add_sym_4s (const char *name, int elemental,
5 arguments. */
static void
add_sym_5s (const char *name, int elemental,
bt type, int kind, int standard,
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)
add_sym_5s (const char *name, int elemental, bt type, int kind, int standard,
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)
{
gfc_check_f cf;
gfc_simplify_f sf;
......@@ -692,7 +690,7 @@ add_sym_5s (const char *name, int elemental,
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
a5, type5, kind5, optional5,
(void*)0);
(void *) 0);
}
......@@ -701,9 +699,8 @@ add_sym_5s (const char *name, int elemental,
a name is not found. */
static gfc_intrinsic_sym *
find_sym (gfc_intrinsic_sym * start, int n, const char *name)
find_sym (gfc_intrinsic_sym *start, int n, const char *name)
{
while (n > 0)
{
if (strcmp (name, start->name) == 0)
......@@ -739,7 +736,6 @@ gfc_find_function (const char *name)
static gfc_intrinsic_sym *
find_subroutine (const char *name)
{
return find_sym (subroutines, nsub, name);
}
......@@ -795,9 +791,8 @@ gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
int
gfc_intrinsic_name (const char *name, int subroutine_flag)
{
return subroutine_flag ?
find_subroutine (name) != NULL : gfc_find_function (name) != NULL;
return subroutine_flag ? find_subroutine (name) != NULL
: gfc_find_function (name) != NULL;
}
......@@ -852,7 +847,6 @@ make_generic (const char *name, gfc_generic_isym_id generic_id, int standard)
static void
make_alias (const char *name, int standard)
{
/* First check that the intrinsic belongs to the selected standard.
If not, don't add it to the symbol list. */
if (!(gfc_option.allow_std & standard)
......@@ -880,21 +874,22 @@ make_alias (const char *name, int standard)
}
}
/* Make the current subroutine noreturn. */
static void
make_noreturn(void)
make_noreturn (void)
{
if (sizing == SZ_NOTHING)
next_sym[-1].noreturn = 1;
next_sym[-1].noreturn = 1;
}
/* Add intrinsic functions. */
static void
add_functions (void)
{
/* Argument names as in the standard (to be used as argument keywords). */
const char
*a = "a", *f = "field", *pt = "pointer", *tg = "target",
......@@ -1206,7 +1201,7 @@ add_functions (void)
GFC_STD_F2003, NULL, NULL, NULL);
make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
GFC_STD_F2003);
GFC_STD_F2003);
add_sym_2 ("complex", ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
......@@ -1277,7 +1272,7 @@ add_functions (void)
make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
add_sym_1 ("ctime", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
gfc_check_ctime, NULL, gfc_resolve_ctime,
gfc_check_ctime, NULL, gfc_resolve_ctime,
tm, BT_INTEGER, di, REQUIRED);
make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
......@@ -1613,7 +1608,7 @@ add_functions (void)
/* The following function is for G77 compatibility. */
add_sym_1 ("irand", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU,
gfc_check_irand, NULL, NULL,
gfc_check_irand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
......@@ -1816,7 +1811,7 @@ add_functions (void)
make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
add_sym_3red ("maxval", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
......@@ -1844,27 +1839,27 @@ add_functions (void)
add_sym_1m ("min", ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("min0", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
gfc_check_min_max_integer, gfc_simplify_min, NULL,
a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
add_sym_1m ("amin0", ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_min_max_integer, gfc_simplify_min, NULL,
a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
add_sym_1m ("amin1", ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_min_max_real, gfc_simplify_min, NULL,
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("min1", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
gfc_check_min_max_real, gfc_simplify_min, NULL,
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("dmin1", ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
gfc_check_min_max_double, gfc_simplify_min, NULL,
a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
......@@ -1882,7 +1877,7 @@ add_functions (void)
make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
add_sym_3red ("minval", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_minval_maxval, NULL, gfc_resolve_minval,
gfc_check_minval_maxval, NULL, gfc_resolve_minval,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
......@@ -1916,7 +1911,7 @@ add_functions (void)
add_sym_1 ("new_line", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc,
GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
i, BT_CHARACTER, dc, REQUIRED);
i, BT_CHARACTER, dc, REQUIRED);
add_sym_2 ("nint", ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
......@@ -1960,7 +1955,7 @@ add_functions (void)
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
add_sym_3red ("product", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_product_sum, NULL, gfc_resolve_product,
gfc_check_product_sum, NULL, gfc_resolve_product,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
......@@ -1974,8 +1969,8 @@ add_functions (void)
/* The following function is for G77 compatibility. */
add_sym_1 ("rand", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
gfc_check_rand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
gfc_check_rand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
/* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
use slightly different shoddy multiplicative congruential PRNG. */
......@@ -2181,7 +2176,7 @@ add_functions (void)
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
add_sym_3red ("sum", NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_product_sum, NULL, gfc_resolve_sum,
gfc_check_product_sum, NULL, gfc_resolve_sum,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
......@@ -2255,8 +2250,8 @@ add_functions (void)
make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
add_sym_1 ("ttynam", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
gfc_check_ttynam, NULL, gfc_resolve_ttynam,
ut, BT_INTEGER, di, REQUIRED);
gfc_check_ttynam, NULL, gfc_resolve_ttynam,
ut, BT_INTEGER, di, REQUIRED);
make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
......@@ -2295,11 +2290,10 @@ add_functions (void)
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
add_sym_1 ("loc", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
gfc_check_loc, NULL, gfc_resolve_loc,
ar, BT_UNKNOWN, 0, REQUIRED);
gfc_check_loc, NULL, gfc_resolve_loc,
ar, BT_UNKNOWN, 0, REQUIRED);
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
}
......@@ -2362,11 +2356,11 @@ add_subroutines (void)
tm, BT_REAL, dr, REQUIRED);
add_sym_2s ("chdir", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("chmod", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
......@@ -2377,42 +2371,44 @@ add_subroutines (void)
/* More G77 compatibility garbage. */
add_sym_2s ("etime", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_2s ("dtime", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_1s ("fdate", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
dt, BT_CHARACTER, dc, REQUIRED);
gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
dt, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("gerror", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
dc, REQUIRED);
add_sym_2s ("getcwd", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("getenv", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, NULL,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
REQUIRED);
add_sym_2s ("getarg", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getarg,
c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("getlog", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
dc, REQUIRED);
/* F2003 commandline routines. */
add_sym_3s ("get_command", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_command,
com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
com, BT_CHARACTER, dc, OPTIONAL,
length, BT_INTEGER, di, OPTIONAL,
st, BT_INTEGER, di, OPTIONAL);
add_sym_4s ("get_command_argument", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
......@@ -2423,8 +2419,9 @@ add_subroutines (void)
/* F2003 subroutine to get environment variables. */
add_sym_5s ("get_environment_variable", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_environment_variable,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
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);
......@@ -2444,7 +2441,7 @@ add_subroutines (void)
h, BT_REAL, dr, REQUIRED);
add_sym_3s ("random_seed", 0, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_random_seed, NULL, NULL,
gfc_check_random_seed, NULL, NULL,
sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
gt, BT_INTEGER, di, OPTIONAL);
......@@ -2455,11 +2452,11 @@ add_subroutines (void)
st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("srand", 0, BT_UNKNOWN, di, GFC_STD_GNU,
gfc_check_srand, NULL, gfc_resolve_srand,
gfc_check_srand, NULL, gfc_resolve_srand,
c, BT_INTEGER, 4, REQUIRED);
add_sym_1s ("exit", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_exit, NULL, gfc_resolve_exit,
gfc_check_exit, NULL, gfc_resolve_exit,
c, BT_INTEGER, di, OPTIONAL);
if ((gfc_option.allow_std & GFC_STD_GNU) || gfc_option.flag_all_intrinsics)
......@@ -2495,7 +2492,7 @@ add_subroutines (void)
ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
add_sym_2s ("hostnm", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("kill", 0, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
......@@ -2503,21 +2500,21 @@ add_subroutines (void)
val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("link", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_link_sub, NULL, gfc_resolve_link_sub,
gfc_check_link_sub, NULL, gfc_resolve_link_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("perror", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_perror, NULL, gfc_resolve_perror,
gfc_check_perror, NULL, gfc_resolve_perror,
c, BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("rename", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("sleep", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
val, BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("fstat", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
......@@ -2541,7 +2538,7 @@ add_subroutines (void)
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("symlnk", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
......@@ -2550,22 +2547,21 @@ add_subroutines (void)
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("system_clock", 0, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
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_2s ("ttynam", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
add_sym_2s ("umask", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("unlink", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
}
......@@ -2574,7 +2570,6 @@ add_subroutines (void)
static void
add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
{
gfc_typespec from, to;
gfc_intrinsic_sym *sym;
......@@ -2772,7 +2767,7 @@ gfc_intrinsic_done_1 (void)
have been left behind by a sort against some formal argument list. */
static void
remove_nullargs (gfc_actual_arglist ** ap)
remove_nullargs (gfc_actual_arglist **ap)
{
gfc_actual_arglist *head, *tail, *next;
......@@ -2812,10 +2807,9 @@ remove_nullargs (gfc_actual_arglist ** ap)
return FAILURE. */
static try
sort_actual (const char *name, gfc_actual_arglist ** ap,
gfc_intrinsic_arg * formal, locus * where)
sort_actual (const char *name, gfc_actual_arglist **ap,
gfc_intrinsic_arg *formal, locus *where)
{
gfc_actual_arglist *actual, *a;
gfc_intrinsic_arg *f;
......@@ -2832,7 +2826,7 @@ sort_actual (const char *name, gfc_actual_arglist ** ap,
return SUCCESS;
for (;;)
{ /* Put the nonkeyword arguments in a 1:1 correspondence */
{ /* Put the nonkeyword arguments in a 1:1 correspondence */
if (f == NULL)
break;
if (a == NULL)
......@@ -2869,7 +2863,7 @@ keywords:
"context", where);
else
gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
a->name, name, where);
a->name, name, where);
return FAILURE;
}
......@@ -2934,7 +2928,7 @@ do_sort:
for arrayness here. */
static try
check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
int error_flag)
{
gfc_actual_arglist *actual;
......@@ -2953,11 +2947,11 @@ check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
{
if (error_flag)
gfc_error
("Type of argument '%s' in call to '%s' at %L should be "
"%s, not %s", gfc_current_intrinsic_arg[i],
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
gfc_error ("Type of argument '%s' in call to '%s' at %L should "
"be %s, not %s", gfc_current_intrinsic_arg[i],
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts),
gfc_typename (&actual->expr->ts));
return FAILURE;
}
}
......@@ -2971,7 +2965,7 @@ check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
of the result. This may involve calling a resolution subroutine. */
static void
resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
gfc_actual_arglist *arg;
......@@ -3058,7 +3052,7 @@ resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
if nothing has changed in the expression itself. */
static try
do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
{
gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
gfc_actual_arglist *arg;
......@@ -3173,7 +3167,7 @@ finish:
list cannot match any intrinsic. */
static void
init_arglist (gfc_intrinsic_sym * isym)
init_arglist (gfc_intrinsic_sym *isym)
{
gfc_intrinsic_arg *formal;
int i;
......@@ -3196,7 +3190,7 @@ init_arglist (gfc_intrinsic_sym * isym)
and intrinsic match, FAILURE otherwise. */
static try
check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
{
gfc_actual_arglist *arg, **ap;
int r;
......@@ -3218,8 +3212,7 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
return FAILURE;
if (specific->check.f3ml == gfc_check_minloc_maxloc)
/* This is special because we might have to reorder the argument
list. */
/* This is special because we might have to reorder the argument list. */
t = gfc_check_minloc_maxloc (*ap);
else if (specific->check.f3red == gfc_check_minval_maxval)
/* This is also special because we also might have to reorder the
......@@ -3257,9 +3250,8 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
if (arg->expr->rank != r)
{
gfc_error
("Ranks of arguments to elemental intrinsic '%s' differ "
"at %L", specific->name, &arg->expr->where);
gfc_error ("Ranks of arguments to elemental intrinsic '%s' "
"differ at %L", specific->name, &arg->expr->where);
return FAILURE;
}
}
......@@ -3299,7 +3291,7 @@ gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
has chosen. */
static void
check_intrinsic_standard (const char *name, int standard, locus * where)
check_intrinsic_standard (const char *name, int standard, locus *where)
{
if (!gfc_option.warn_nonstd_intrinsics)
return;
......@@ -3313,17 +3305,17 @@ check_intrinsic_standard (const char *name, int standard, locus * where)
We return:
MATCH_YES if the call corresponds to an intrinsic, simplification
is done if possible.
is done if possible.
MATCH_NO if the call does not correspond to an intrinsic
MATCH_ERROR if the call corresponds to an intrinsic but there was an
error during the simplification process.
error during the simplification process.
The error_flag parameter enables an error reporting. */
match
gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
{
gfc_intrinsic_sym *isym, *specific;
gfc_actual_arglist *actual;
......@@ -3332,7 +3324,7 @@ gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
if (expr->value.function.isym != NULL)
return (do_simplify (expr->value.function.isym, expr) == FAILURE)
? MATCH_ERROR : MATCH_YES;
? MATCH_ERROR : MATCH_YES;
gfc_suppress_error = !error_flag;
flag = 0;
......@@ -3407,8 +3399,8 @@ got_specific:
if (gfc_init_expr && flag && gfc_init_expr_extensions (specific))
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
"nonstandard initialization expression at %L", &expr->where)
== FAILURE)
"nonstandard initialization expression at %L",
&expr->where) == FAILURE)
{
return MATCH_ERROR;
}
......@@ -3426,7 +3418,7 @@ got_specific:
correspond). */
match
gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
{
gfc_intrinsic_sym *isym;
const char *name;
......@@ -3485,7 +3477,7 @@ fail:
/* Call gfc_convert_type() with warning enabled. */
try
gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
{
return gfc_convert_type_warn (expr, ts, eflag, 1);
}
......@@ -3502,8 +3494,7 @@ gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
'wflag' controls the warning related to conversion. */
try
gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
int wflag)
gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
{
gfc_intrinsic_sym *sym;
gfc_typespec from_ts;
......@@ -3519,8 +3510,7 @@ gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
/* NULL and zero size arrays get their type here. */
if (expr->expr_type == EXPR_NULL
|| (expr->expr_type == EXPR_ARRAY
&& expr->value.constructor == NULL))
|| (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
{
/* Sometimes the RHS acquire the type. */
expr->ts = *ts;
......@@ -3530,8 +3520,7 @@ gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
if (expr->ts.type == BT_UNKNOWN)
goto bad;
if (expr->ts.type == BT_DERIVED
&& ts->type == BT_DERIVED
if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
&& gfc_compare_types (&expr->ts, ts))
return SUCCESS;
......
gcc/fortran/io.c
/* Deal with I/O statements & related stuff.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
Foundation, Inc.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
......@@ -27,9 +27,9 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "match.h"
#include "parse.h"
gfc_st_label format_asterisk =
{0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
0, {NULL, NULL}};
gfc_st_label
format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
0, {NULL, NULL}};
typedef struct
{
......@@ -52,7 +52,7 @@ static const io_tag
tag_unit = {"UNIT", " unit = %e", BT_INTEGER},
tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER},
tag_rec = {"REC", " rec = %e", BT_INTEGER},
tag_spos = {"POSITION", " pos = %e", BT_INTEGER},
tag_spos = {"POSITION", " pos = %e", BT_INTEGER},
tag_format = {"FORMAT", NULL, BT_CHARACTER},
tag_iomsg = {"IOMSG", " iomsg = %e", BT_CHARACTER},
tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER},
......@@ -152,14 +152,13 @@ next_char (int in_string)
static void
unget_char (void)
{
use_last_char = 1;
}
/* Eat up the spaces and return a character. */
static char
next_char_not_space(void)
next_char_not_space (void)
{
char c;
do
......@@ -210,15 +209,15 @@ format_lex (void)
do
{
c = next_char_not_space ();
if(ISDIGIT (c))
value = 10 * value + c - '0';
if (ISDIGIT (c))
value = 10 * value + c - '0';
}
while (ISDIGIT (c));
unget_char ();
if (negative_flag)
value = -value;
value = -value;
token = FMT_SIGNED_INT;
break;
......@@ -242,8 +241,8 @@ format_lex (void)
c = next_char_not_space ();
if (c != '0')
zflag = 0;
if (ISDIGIT (c))
value = 10 * value + c - '0';
if (ISDIGIT (c))
value = 10 * value + c - '0';
}
while (ISDIGIT (c));
......@@ -343,7 +342,7 @@ format_lex (void)
break;
}
}
value++;
value++;
}
break;
......@@ -506,8 +505,8 @@ format_item_1:
t = format_lex ();
if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
== FAILURE)
return FAILURE;
== FAILURE)
return FAILURE;
if (t != FMT_RPAREN || level > 0)
{
gfc_warning ("$ should be the last specifier in format at %C");
......@@ -573,8 +572,8 @@ data_desc:
switch (gfc_notification_std (GFC_STD_GNU))
{
case WARNING:
gfc_warning
("Extension: Missing positive width after L descriptor at %C");
gfc_warning ("Extension: Missing positive width after L "
"descriptor at %C");
saved_token = t;
break;
......@@ -660,7 +659,7 @@ data_desc:
if (t != FMT_PERIOD)
{
/* Warn if -std=legacy, otherwise error. */
if (gfc_option.warn_std != 0)
if (gfc_option.warn_std != 0)
gfc_error_now ("Period required in format specifier at %C");
else
gfc_warning ("Period required in format specifier at %C");
......@@ -680,16 +679,16 @@ data_desc:
case FMT_H:
if(mode == MODE_STRING)
{
format_string += value;
format_length -= value;
format_string += value;
format_length -= value;
}
else
{
while(repeat >0)
{
next_char(1);
repeat -- ;
}
while (repeat >0)
{
next_char (1);
repeat -- ;
}
}
break;
......@@ -821,7 +820,7 @@ syntax:
gfc_warning ("%s in format string at %C", error);
/* TODO: More elaborate measures are needed to show where a problem
is within a format string that has been calculated. */
is within a format string that has been calculated. */
}
rv = FAILURE;
......@@ -835,9 +834,8 @@ finished:
like a format string. */
static void
check_format_string (gfc_expr * e)
check_format_string (gfc_expr *e)
{
mode = MODE_STRING;
format_string = e->value.character.string;
check_format ();
......@@ -857,7 +855,7 @@ gfc_match_format (void)
locus start;
if (gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
&& gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
{
gfc_error ("Format statement in module main block at %C");
return MATCH_ERROR;
......@@ -897,7 +895,7 @@ gfc_match_format (void)
e->ts.type = BT_CHARACTER;
e->ts.kind = gfc_default_character_kind;
e->where = start;
e->value.character.string = format_string = gfc_getmem(format_length+1);
e->value.character.string = format_string = gfc_getmem (format_length + 1);
e->value.character.length = format_length;
gfc_statement_label->format = e;
......@@ -912,7 +910,7 @@ gfc_match_format (void)
/* Match an expression I/O tag of some sort. */
static match
match_etag (const io_tag * tag, gfc_expr ** v)
match_etag (const io_tag *tag, gfc_expr **v)
{
gfc_expr *result;
match m;
......@@ -936,7 +934,7 @@ match_etag (const io_tag * tag, gfc_expr ** v)
/* Match a variable I/O tag of some sort. */
static match
match_vtag (const io_tag * tag, gfc_expr ** v)
match_vtag (const io_tag *tag, gfc_expr **v)
{
gfc_expr *result;
match m;
......@@ -989,7 +987,7 @@ match_out_tag(const io_tag *tag, gfc_expr **result)
/* Match a label I/O tag. */
static match
match_ltag (const io_tag * tag, gfc_st_label ** label)
match_ltag (const io_tag *tag, gfc_st_label ** label)
{
match m;
gfc_st_label *old;
......@@ -1013,9 +1011,8 @@ match_ltag (const io_tag * tag, gfc_st_label ** label)
/* Do expression resolution and type-checking on an expression tag. */
static try
resolve_tag (const io_tag * tag, gfc_expr * e)
resolve_tag (const io_tag *tag, gfc_expr *e)
{
if (e == NULL)
return SUCCESS;
......@@ -1025,7 +1022,7 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
if (e->ts.type != tag->type && tag != &tag_format)
{
gfc_error ("%s tag at %L must be of type %s", tag->name,
&e->where, gfc_basic_typename (tag->type));
&e->where, gfc_basic_typename (tag->type));
return FAILURE;
}
......@@ -1044,32 +1041,34 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
of integer or character type. The integer variable should be
ASSIGNED. */
if (e->symtree == NULL || e->symtree->n.sym->as == NULL
|| e->symtree->n.sym->as->rank == 0)
|| e->symtree->n.sym->as->rank == 0)
{
if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
{
gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
&e->where, gfc_basic_typename (BT_CHARACTER),
gfc_basic_typename (BT_INTEGER));
&e->where, gfc_basic_typename (BT_CHARACTER),
gfc_basic_typename (BT_INTEGER));
return FAILURE;
}
else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: ASSIGNED variable in FORMAT tag at %L",
&e->where) == FAILURE)
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGNED "
"variable in FORMAT tag at %L", &e->where)
== FAILURE)
return FAILURE;
if (e->symtree->n.sym->attr.assign != 1)
{
gfc_error ("Variable '%s' at %L has not been assigned a "
"format label", e->symtree->n.sym->name, &e->where);
"format label", e->symtree->n.sym->name,
&e->where);
return FAILURE;
}
}
else if (e->ts.type == BT_INTEGER)
{
gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED "
"variable", gfc_basic_typename (e->ts.type), &e->where);
"variable", gfc_basic_typename (e->ts.type),
&e->where);
return FAILURE;
}
......@@ -1082,16 +1081,16 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
assigned an Hollerith constant. */
if (e->ts.type == BT_CHARACTER)
{
if (gfc_notify_std (GFC_STD_GNU,
"Extension: Character array in FORMAT tag at %L",
&e->where) == FAILURE)
if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
"in FORMAT tag at %L", &e->where)
== FAILURE)
return FAILURE;
}
else
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Extension: Non-character in FORMAT tag at %L",
&e->where) == FAILURE)
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
"in FORMAT tag at %L", &e->where)
== FAILURE)
return FAILURE;
}
return SUCCESS;
......@@ -1115,16 +1114,16 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
"INTEGER in IOSTAT tag at %L",
&e->where) == FAILURE)
"INTEGER in IOSTAT tag at %L", &e->where)
== FAILURE)
return FAILURE;
}
if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
"INTEGER in SIZE tag at %L",
&e->where) == FAILURE)
"INTEGER in SIZE tag at %L", &e->where)
== FAILURE)
return FAILURE;
}
......@@ -1138,8 +1137,8 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
if (tag == &tag_iolength && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
"INTEGER in IOLENGTH tag at %L",
&e->where) == FAILURE)
"INTEGER in IOLENGTH tag at %L", &e->where)
== FAILURE)
return FAILURE;
}
}
......@@ -1151,7 +1150,7 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
/* Match a single tag of an OPEN statement. */
static match
match_open_element (gfc_open * open)
match_open_element (gfc_open *open)
{
match m;
......@@ -1208,9 +1207,8 @@ match_open_element (gfc_open * open)
/* Free the gfc_open structure and all the expressions it contains. */
void
gfc_free_open (gfc_open * open)
gfc_free_open (gfc_open *open)
{
if (open == NULL)
return;
......@@ -1228,7 +1226,6 @@ gfc_free_open (gfc_open * open)
gfc_free_expr (open->delim);
gfc_free_expr (open->pad);
gfc_free_expr (open->convert);
gfc_free (open);
}
......@@ -1236,7 +1233,7 @@ gfc_free_open (gfc_open * open)
/* Resolve everything in a gfc_open structure. */
try
gfc_resolve_open (gfc_open * open)
gfc_resolve_open (gfc_open *open)
{
RESOLVE_TAG (&tag_unit, open->unit);
......@@ -1247,7 +1244,6 @@ gfc_resolve_open (gfc_open * open)
RESOLVE_TAG (&tag_e_access, open->access);
RESOLVE_TAG (&tag_e_form, open->form);
RESOLVE_TAG (&tag_e_recl, open->recl);
RESOLVE_TAG (&tag_e_blank, open->blank);
RESOLVE_TAG (&tag_e_position, open->position);
RESOLVE_TAG (&tag_e_action, open->action);
......@@ -1262,20 +1258,20 @@ gfc_resolve_open (gfc_open * open)
}
/* Check if a given value for a SPECIFIER is either in the list of values
allowed in F95 or F2003, issuing an error message and returning a zero
value if it is not allowed. */
static int
compare_to_allowed_values (const char * specifier, const char * allowed[],
const char * allowed_f2003[],
const char * allowed_gnu[], char * value,
const char * statement, bool warn)
compare_to_allowed_values (const char *specifier, const char *allowed[],
const char *allowed_f2003[],
const char *allowed_gnu[], char *value,
const char *statement, bool warn)
{
int i;
unsigned int len;
len = strlen(value);
len = strlen (value);
if (len > 0)
{
for (len--; len > 0; len--)
......@@ -1285,13 +1281,14 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
}
for (i = 0; allowed[i]; i++)
if (len == strlen(allowed[i])
&& strncasecmp (value, allowed[i], strlen(allowed[i])) == 0)
if (len == strlen (allowed[i])
&& strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
return 1;
for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
if (len == strlen(allowed_f2003[i])
&& strncasecmp (value, allowed_f2003[i], strlen(allowed_f2003[i])) == 0)
if (len == strlen (allowed_f2003[i])
&& strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i]))
== 0)
{
notification n = gfc_notification_std (GFC_STD_F2003);
......@@ -1316,8 +1313,8 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
}
for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
if (len == strlen(allowed_gnu[i])
&& strncasecmp (value, allowed_gnu[i], strlen(allowed_gnu[i])) == 0)
if (len == strlen (allowed_gnu[i])
&& strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0)
{
notification n = gfc_notification_std (GFC_STD_GNU);
......@@ -1355,6 +1352,7 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
}
}
/* Match an OPEN statement. */
match
......@@ -1410,9 +1408,9 @@ gfc_match_open (void)
/* Checks on the ACCESS specifier. */
if (open->access && open->access->expr_type == EXPR_CONSTANT)
{
static const char * access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
static const char * access_f2003[] = { "STREAM", NULL };
static const char * access_gnu[] = { "APPEND", NULL };
static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
static const char *access_f2003[] = { "STREAM", NULL };
static const char *access_gnu[] = { "APPEND", NULL };
if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
access_gnu,
......@@ -1424,7 +1422,7 @@ gfc_match_open (void)
/* Checks on the ACTION specifier. */
if (open->action && open->action->expr_type == EXPR_CONSTANT)
{
static const char * action[] = { "READ", "WRITE", "READWRITE", NULL };
static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
open->action->value.character.string,
......@@ -1448,7 +1446,7 @@ gfc_match_open (void)
/* Checks on the BLANK specifier. */
if (open->blank && open->blank->expr_type == EXPR_CONSTANT)
{
static const char * blank[] = { "ZERO", "NULL", NULL };
static const char *blank[] = { "ZERO", "NULL", NULL };
if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
open->blank->value.character.string,
......@@ -1471,7 +1469,7 @@ gfc_match_open (void)
/* Checks on the DELIM specifier. */
if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
{
static const char * delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
open->delim->value.character.string,
......@@ -1494,7 +1492,7 @@ gfc_match_open (void)
/* Checks on the FORM specifier. */
if (open->form && open->form->expr_type == EXPR_CONSTANT)
{
static const char * form[] = { "FORMATTED", "UNFORMATTED", NULL };
static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
open->form->value.character.string,
......@@ -1505,7 +1503,7 @@ gfc_match_open (void)
/* Checks on the PAD specifier. */
if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
{
static const char * pad[] = { "YES", "NO", NULL };
static const char *pad[] = { "YES", "NO", NULL };
if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
open->pad->value.character.string,
......@@ -1516,7 +1514,7 @@ gfc_match_open (void)
/* Checks on the POSITION specifier. */
if (open->position && open->position->expr_type == EXPR_CONSTANT)
{
static const char * position[] = { "ASIS", "REWIND", "APPEND", NULL };
static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
open->position->value.character.string,
......@@ -1572,7 +1570,7 @@ gfc_match_open (void)
/* Checks on the STATUS specifier. */
if (open->status && open->status->expr_type == EXPR_CONSTANT)
{
static const char * status[] = { "OLD", "NEW", "SCRATCH",
static const char *status[] = { "OLD", "NEW", "SCRATCH",
"REPLACE", "UNKNOWN", NULL };
if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
......@@ -1581,23 +1579,25 @@ gfc_match_open (void)
goto cleanup;
/* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
the FILE= specifier shall appear. */
if (open->file == NULL &&
(strncasecmp (open->status->value.character.string, "replace", 7) == 0
|| strncasecmp (open->status->value.character.string, "new", 3) == 0))
the FILE= specifier shall appear. */
if (open->file == NULL
&& (strncasecmp (open->status->value.character.string, "replace", 7)
== 0
|| strncasecmp (open->status->value.character.string, "new", 3)
== 0))
{
warn_or_error ("The STATUS specified in OPEN statement at %C is '%s' "
"and no FILE specifier is present",
warn_or_error ("The STATUS specified in OPEN statement at %C is "
"'%s' and no FILE specifier is present",
open->status->value.character.string);
}
/* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
the FILE= specifier shall not appear. */
if (strncasecmp (open->status->value.character.string, "scratch", 7) == 0
&& open->file)
if (strncasecmp (open->status->value.character.string, "scratch", 7)
== 0 && open->file)
{
warn_or_error ("The STATUS specified in OPEN statement at %C cannot "
"have the value SCRATCH if a FILE specifier "
warn_or_error ("The STATUS specified in OPEN statement at %C "
"cannot have the value SCRATCH if a FILE specifier "
"is present");
}
}
......@@ -1612,10 +1612,11 @@ gfc_match_open (void)
&& strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0)
{
const char * spec = (open->delim ? "DELIM " : (open->pad ? "PAD " :
open->blank ? "BLANK " : ""));
const char *spec = (open->delim ? "DELIM "
: (open->pad ? "PAD " : open->blank
? "BLANK " : ""));
warn_or_error ("%sspecifier at %C not allowed in OPEN statement for "
warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
"unformatted I/O", spec);
}
......@@ -1626,7 +1627,8 @@ gfc_match_open (void)
"stream I/O");
}
if (open->position && open->access && open->access->expr_type == EXPR_CONSTANT
if (open->position
&& open->access && open->access->expr_type == EXPR_CONSTANT
&& !(strncasecmp (open->access->value.character.string,
"sequential", 10) == 0
|| strncasecmp (open->access->value.character.string,
......@@ -1656,9 +1658,8 @@ cleanup:
/* Free a gfc_close structure an all its expressions. */
void
gfc_free_close (gfc_close * close)
gfc_free_close (gfc_close *close)
{
if (close == NULL)
return;
......@@ -1666,7 +1667,6 @@ gfc_free_close (gfc_close * close)
gfc_free_expr (close->iomsg);
gfc_free_expr (close->iostat);
gfc_free_expr (close->status);
gfc_free (close);
}
......@@ -1674,7 +1674,7 @@ gfc_free_close (gfc_close * close)
/* Match elements of a CLOSE statement. */
static match
match_close_element (gfc_close * close)
match_close_element (gfc_close *close)
{
match m;
......@@ -1754,7 +1754,7 @@ gfc_match_close (void)
/* Checks on the STATUS specifier. */
if (close->status && close->status->expr_type == EXPR_CONSTANT)
{
static const char * status[] = { "KEEP", "DELETE", NULL };
static const char *status[] = { "KEEP", "DELETE", NULL };
if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
close->status->value.character.string,
......@@ -1778,9 +1778,8 @@ cleanup:
/* Resolve everything in a gfc_close structure. */
try
gfc_resolve_close (gfc_close * close)
gfc_resolve_close (gfc_close *close)
{
RESOLVE_TAG (&tag_unit, close->unit);
RESOLVE_TAG (&tag_iomsg, close->iomsg);
RESOLVE_TAG (&tag_iostat, close->iostat);
......@@ -1796,9 +1795,8 @@ gfc_resolve_close (gfc_close * close)
/* Free a gfc_filepos structure. */
void
gfc_free_filepos (gfc_filepos * fp)
gfc_free_filepos (gfc_filepos *fp)
{
gfc_free_expr (fp->unit);
gfc_free_expr (fp->iomsg);
gfc_free_expr (fp->iostat);
......@@ -1809,7 +1807,7 @@ gfc_free_filepos (gfc_filepos * fp)
/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
static match
match_file_element (gfc_filepos * fp)
match_file_element (gfc_filepos *fp)
{
match m;
......@@ -1904,9 +1902,8 @@ cleanup:
try
gfc_resolve_filepos (gfc_filepos * fp)
gfc_resolve_filepos (gfc_filepos *fp)
{
RESOLVE_TAG (&tag_unit, fp->unit);
RESOLVE_TAG (&tag_iostat, fp->iostat);
RESOLVE_TAG (&tag_iomsg, fp->iomsg);
......@@ -1923,28 +1920,26 @@ gfc_resolve_filepos (gfc_filepos * fp)
match
gfc_match_endfile (void)
{
return match_filepos (ST_END_FILE, EXEC_ENDFILE);
}
match
gfc_match_backspace (void)
{
return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
}
match
gfc_match_rewind (void)
{
return match_filepos (ST_REWIND, EXEC_REWIND);
}
match
gfc_match_flush (void)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
== FAILURE)
return MATCH_ERROR;
return match_filepos (ST_FLUSH, EXEC_FLUSH);
......@@ -1976,7 +1971,7 @@ default_unit (io_kind k)
/* Match a unit specification for a data transfer statement. */
static match
match_dt_unit (io_kind k, gfc_dt * dt)
match_dt_unit (io_kind k, gfc_dt *dt)
{
gfc_expr *e;
......@@ -2012,7 +2007,7 @@ conflict:
/* Match a format specification. */
static match
match_dt_format (gfc_dt * dt)
match_dt_format (gfc_dt *dt)
{
locus where;
gfc_expr *e;
......@@ -2070,7 +2065,7 @@ conflict:
nonzero if we find such a variable. */
static int
check_namelist (gfc_symbol * sym)
check_namelist (gfc_symbol *sym)
{
gfc_namelist *p;
......@@ -2089,7 +2084,7 @@ check_namelist (gfc_symbol * sym)
/* Match a single data transfer element. */
static match
match_dt_element (io_kind k, gfc_dt * dt)
match_dt_element (io_kind k, gfc_dt *dt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
......@@ -2163,8 +2158,8 @@ match_dt_element (io_kind k, gfc_dt * dt)
{
if (k == M_WRITE)
{
gfc_error ("END tag at %C not allowed in output statement");
return MATCH_ERROR;
gfc_error ("END tag at %C not allowed in output statement");
return MATCH_ERROR;
}
dt->end_where = gfc_current_locus;
}
......@@ -2184,9 +2179,8 @@ match_dt_element (io_kind k, gfc_dt * dt)
/* Free a data transfer structure and everything below it. */
void
gfc_free_dt (gfc_dt * dt)
gfc_free_dt (gfc_dt *dt)
{
if (dt == NULL)
return;
......@@ -2197,7 +2191,6 @@ gfc_free_dt (gfc_dt * dt)
gfc_free_expr (dt->iomsg);
gfc_free_expr (dt->iostat);
gfc_free_expr (dt->size);
gfc_free (dt);
}
......@@ -2205,7 +2198,7 @@ gfc_free_dt (gfc_dt * dt)
/* Resolve everything in a gfc_dt structure. */
try
gfc_resolve_dt (gfc_dt * dt)
gfc_resolve_dt (gfc_dt *dt)
{
gfc_expr *e;
......@@ -2220,12 +2213,10 @@ gfc_resolve_dt (gfc_dt * dt)
e = dt->io_unit;
if (gfc_resolve_expr (e) == SUCCESS
&& (e->ts.type != BT_INTEGER
&& (e->ts.type != BT_CHARACTER
|| e->expr_type != EXPR_VARIABLE)))
&& (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
{
gfc_error
("UNIT specification at %L must be an INTEGER expression or a "
"CHARACTER variable", &e->where);
gfc_error ("UNIT specification at %L must be an INTEGER expression "
"or a CHARACTER variable", &e->where);
return FAILURE;
}
......@@ -2233,8 +2224,7 @@ gfc_resolve_dt (gfc_dt * dt)
{
if (gfc_has_vector_index (e))
{
gfc_error ("Internal unit with vector subscript at %L",
&e->where);
gfc_error ("Internal unit with vector subscript at %L", &e->where);
return FAILURE;
}
}
......@@ -2286,7 +2276,7 @@ gfc_resolve_dt (gfc_dt * dt)
&& dt->format_label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
&dt->format_label->where);
&dt->format_label->where);
return FAILURE;
}
return SUCCESS;
......@@ -2329,10 +2319,10 @@ io_kind_name (io_kind k)
which is equivalent to a single IO element. This function is
mutually recursive with match_io_element(). */
static match match_io_element (io_kind k, gfc_code **);
static match match_io_element (io_kind, gfc_code **);
static match
match_io_iterator (io_kind k, gfc_code ** result)
match_io_iterator (io_kind k, gfc_code **result)
{
gfc_code *head, *tail, *new;
gfc_iterator *iter;
......@@ -2421,7 +2411,7 @@ cleanup:
expression or an IO Iterator. */
static match
match_io_element (io_kind k, gfc_code ** cpp)
match_io_element (io_kind k, gfc_code **cpp)
{
gfc_expr *expr;
gfc_code *cp;
......@@ -2453,9 +2443,8 @@ match_io_element (io_kind k, gfc_code ** cpp)
case M_READ:
if (expr->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error
("Variable '%s' in input list at %C cannot be INTENT(IN)",
expr->symtree->n.sym->name);
gfc_error ("Variable '%s' in input list at %C cannot be "
"INTENT(IN)", expr->symtree->n.sym->name);
m = MATCH_ERROR;
}
......@@ -2479,9 +2468,9 @@ match_io_element (io_kind k, gfc_code ** cpp)
&& current_dt->io_unit->expr_type == EXPR_VARIABLE
&& gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
{
gfc_error
("Cannot write to internal file unit '%s' at %C inside a "
"PURE procedure", current_dt->io_unit->symtree->n.sym->name);
gfc_error ("Cannot write to internal file unit '%s' at %C "
"inside a PURE procedure",
current_dt->io_unit->symtree->n.sym->name);
m = MATCH_ERROR;
}
......@@ -2509,7 +2498,7 @@ match_io_element (io_kind k, gfc_code ** cpp)
/* Match an I/O list, building gfc_code structures as we go. */
static match
match_io_list (io_kind k, gfc_code ** head_p)
match_io_list (io_kind k, gfc_code **head_p)
{
gfc_code *head, *tail, *new;
match m;
......@@ -2551,7 +2540,7 @@ cleanup:
/* Attach the data transfer end node. */
static void
terminate_io (gfc_code * io_code)
terminate_io (gfc_code *io_code)
{
gfc_code *c;
......@@ -2572,7 +2561,8 @@ terminate_io (gfc_code * io_code)
in resolve_tag and others in gfc_resolve_dt. */
static match
check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
locus *spec_end)
{
#define io_constraint(condition,msg,arg)\
if (condition) \
......@@ -2582,14 +2572,14 @@ if (condition) \
}
match m;
gfc_expr * expr;
gfc_symbol * sym = NULL;
gfc_expr *expr;
gfc_symbol *sym = NULL;
m = MATCH_YES;
expr = dt->io_unit;
if (expr && expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER)
&& expr->ts.type == BT_CHARACTER)
{
sym = expr->symtree->n.sym;
......@@ -2606,12 +2596,12 @@ if (condition) \
&dt->rec->where);
if (dt->namelist != NULL)
{
if (gfc_notify_std(GFC_STD_F2003,
"Fortran 2003: Internal file at %L with namelist",
&expr->where) == FAILURE)
m = MATCH_ERROR;
}
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
"at %L with namelist", &expr->where)
== FAILURE)
m = MATCH_ERROR;
}
io_constraint (dt->advance != NULL,
"ADVANCE tag at %L is incompatible with internal file",
......@@ -2621,8 +2611,7 @@ if (condition) \
if (expr && expr->ts.type != BT_CHARACTER)
{
io_constraint (gfc_pure (NULL)
&& (k == M_READ || k == M_WRITE),
io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
"IO UNIT in %s statement at %C must be "
"an internal file in a PURE procedure",
io_kind_name (k));
......@@ -2631,12 +2620,10 @@ if (condition) \
if (k != M_READ)
{
io_constraint (dt->end,
"END tag not allowed with output at %L",
io_constraint (dt->end, "END tag not allowed with output at %L",
&dt->end_where);
io_constraint (dt->eor,
"EOR tag not allowed with output at %L",
io_constraint (dt->eor, "EOR tag not allowed with output at %L",
&dt->eor_where);
io_constraint (k != M_READ && dt->size,
......@@ -2701,9 +2688,8 @@ if (condition) \
"List directed format(*) is not allowed with a "
"ADVANCE=specifier at %L.", &expr->where);
io_constraint (dt->format_expr == NULL
&& dt->format_label == NULL
&& dt->namelist == NULL,
io_constraint (dt->format_expr == NULL && dt->format_label == NULL
&& dt->namelist == NULL,
"the ADVANCE=specifier at %L must appear with an "
"explicit format expression", &expr->where);
......@@ -2740,6 +2726,7 @@ if (condition) \
}
#undef io_constraint
/* Match a READ, WRITE or PRINT statement. */
static match
......@@ -2812,7 +2799,6 @@ match_io (io_kind k)
{
/* Before issuing an error for a malformed 'print (1,*)' type of
error, check for a default-char-expr of the form ('(I0)'). */
if (k == M_PRINT && m == MATCH_YES)
{
/* Reset current locus to get the initial '(' in an expression. */
......@@ -2988,7 +2974,7 @@ gfc_match_print (void)
/* Free a gfc_inquire structure. */
void
gfc_free_inquire (gfc_inquire * inquire)
gfc_free_inquire (gfc_inquire *inquire)
{
if (inquire == NULL)
......@@ -3022,7 +3008,6 @@ gfc_free_inquire (gfc_inquire * inquire)
gfc_free_expr (inquire->iolength);
gfc_free_expr (inquire->convert);
gfc_free_expr (inquire->strm_pos);
gfc_free (inquire);
}
......@@ -3032,7 +3017,7 @@ gfc_free_inquire (gfc_inquire * inquire)
#define RETM if (m != MATCH_NO) return m;
static match
match_inquire_element (gfc_inquire * inquire)
match_inquire_element (gfc_inquire *inquire)
{
match m;
......@@ -3155,15 +3140,15 @@ gfc_match_inquire (void)
if (inquire->unit != NULL && inquire->file != NULL)
{
gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
" UNIT specifiers", &loc);
gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
"UNIT specifiers", &loc);
goto cleanup;
}
if (inquire->unit == NULL && inquire->file == NULL)
{
gfc_error ("INQUIRE statement at %L requires either FILE or"
" UNIT specifier", &loc);
gfc_error ("INQUIRE statement at %L requires either FILE or "
"UNIT specifier", &loc);
goto cleanup;
}
......@@ -3189,9 +3174,8 @@ cleanup:
/* Resolve everything in a gfc_inquire structure. */
try
gfc_resolve_inquire (gfc_inquire * inquire)
gfc_resolve_inquire (gfc_inquire *inquire)
{
RESOLVE_TAG (&tag_unit, inquire->unit);
RESOLVE_TAG (&tag_file, inquire->file);
RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
......
gcc/fortran/iresolve.c
/* Intrinsic function resolution.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
......@@ -35,7 +35,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "gfortran.h"
#include "intrinsic.h"
/* Given printf-like arguments, return a stable version of the result string.
We already have a working, optimized string hashing table in the form of
......@@ -51,9 +50,9 @@ gfc_get_string (const char *format, ...)
tree ident;
va_start (ap, format);
vsnprintf (temp_name, sizeof(temp_name), format, ap);
vsnprintf (temp_name, sizeof (temp_name), format, ap);
va_end (ap);
temp_name[sizeof(temp_name)-1] = 0;
temp_name[sizeof (temp_name) - 1] = 0;
ident = get_identifier (temp_name);
return IDENTIFIER_POINTER (ident);
......@@ -78,77 +77,78 @@ check_charlen_present (gfc_expr *source)
void
gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
{
f->ts = a->ts;
if (f->ts.type == BT_COMPLEX)
f->ts.type = BT_REAL;
f->value.function.name =
gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_access (gfc_expr * f, gfc_expr * name ATTRIBUTE_UNUSED,
gfc_expr * mode ATTRIBUTE_UNUSED)
gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
gfc_expr *mode ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
f->value.function.name = PREFIX("access_func");
f->value.function.name = PREFIX ("access_func");
}
void
gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
{
f->ts.type = BT_REAL;
f->ts.kind = x->ts.kind;
f->value.function.name =
gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
f->ts.kind = gfc_kind_max (i,j);
f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->value.function.name = gfc_get_string ("__and_%c%d",
gfc_type_letter (i->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
void
gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
......@@ -163,20 +163,20 @@ gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
}
/* The resolved name is only used for specific intrinsics where
the return kind is the same as the arg kind. */
f->value.function.name =
gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_aint (f, a, NULL);
}
void
gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
......@@ -187,14 +187,14 @@ gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
f->value.function.name =
gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
}
void
gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
......@@ -210,20 +210,21 @@ gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
/* The resolved name is only used for specific intrinsics where
the return kind is the same as the arg kind. */
f->value.function.name =
gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
a->ts.kind);
}
void
gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_anint (f, a, NULL);
}
void
gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
......@@ -234,58 +235,60 @@ gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
f->value.function.name =
gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
mask->ts.kind);
}
void
gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
gfc_expr * y ATTRIBUTE_UNUSED)
gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
/* Resolve the BESYN and BESJN intrinsics. */
void
gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
{
gfc_typespec ts;
......@@ -301,53 +304,50 @@ gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
void
gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
{
f->ts.type = BT_LOGICAL;
f->ts.kind = gfc_default_logical_kind;
f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
pos->ts.kind);
f->value.function.name
= gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
}
void
gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
: mpz_get_si (kind->value.integer);
f->value.function.name =
gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->ts.kind = (kind == NULL)
? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL) ? gfc_default_character_kind
: mpz_get_si (kind->value.integer);
f->value.function.name =
gfc_get_string ("__char_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->ts.kind = (kind == NULL)
? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__char_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
}
void
gfc_resolve_chdir_sub (gfc_code * c)
gfc_resolve_chdir_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -357,23 +357,23 @@ gfc_resolve_chdir_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_chmod (gfc_expr * f, gfc_expr * name ATTRIBUTE_UNUSED,
gfc_expr * mode ATTRIBUTE_UNUSED)
gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
gfc_expr *mode ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
f->value.function.name = PREFIX("chmod_func");
f->value.function.name = PREFIX ("chmod_func");
}
void
gfc_resolve_chmod_sub (gfc_code * c)
gfc_resolve_chmod_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -383,37 +383,39 @@ gfc_resolve_chmod_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("chmod_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
f->ts.type = BT_COMPLEX;
f->ts.kind = (kind == NULL) ? gfc_default_real_kind
: mpz_get_si (kind->value.integer);
f->ts.kind = (kind == NULL)
? gfc_default_real_kind : mpz_get_si (kind->value.integer);
if (y == NULL)
f->value.function.name =
gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind);
else
f->value.function.name =
gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind,
gfc_type_letter (y->ts.type), y->ts.kind);
f->value.function.name
= gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind,
gfc_type_letter (y->ts.type), y->ts.kind);
}
void
gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
}
void
gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
int kind;
......@@ -434,16 +436,15 @@ gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
f->ts.type = BT_COMPLEX;
f->ts.kind = kind;
f->value.function.name =
gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind,
gfc_type_letter (y->ts.type), y->ts.kind);
f->value.function.name
= gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
gfc_type_letter (x->ts.type), x->ts.kind,
gfc_type_letter (y->ts.type), y->ts.kind);
}
void
gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
......@@ -451,25 +452,25 @@ gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
void
gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
......@@ -481,16 +482,15 @@ gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
f->value.function.name =
gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
gfc_type_letter (mask->ts.type), mask->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
gfc_type_letter (mask->ts.type), mask->ts.kind);
}
void
gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
gfc_expr * shift,
gfc_expr * dim)
gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *dim)
{
int n;
......@@ -520,14 +520,14 @@ gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
if (dim->ts.kind != shift->ts.kind)
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : "");
f->value.function.name
= gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
gfc_typespec ts;
......@@ -544,22 +544,22 @@ gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
gfc_convert_type (time, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("ctime"));
f->value.function.name = gfc_get_string (PREFIX ("ctime"));
}
void
gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_REAL;
f->ts.kind = gfc_default_double_kind;
f->value.function.name =
gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
......@@ -570,18 +570,18 @@ gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
gfc_convert_type(p, &a->ts, 2);
gfc_convert_type (p, &a->ts, 2);
else
gfc_convert_type(a, &p->ts, 2);
gfc_convert_type (a, &p->ts, 2);
}
f->value.function.name =
gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
f->value.function.name
= gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
}
void
gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
......@@ -592,30 +592,25 @@ gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->ts = temp.ts;
f->value.function.name =
gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("dot_product_%c%d"),
gfc_type_letter (f->ts.type), f->ts.kind);
}
void
gfc_resolve_dprod (gfc_expr * f,
gfc_expr * a ATTRIBUTE_UNUSED,
gfc_expr * b ATTRIBUTE_UNUSED)
gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts.kind = gfc_default_double_kind;
f->ts.type = BT_REAL;
f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
}
void
gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
gfc_expr * shift,
gfc_expr * boundary,
gfc_expr * dim)
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *boundary, gfc_expr *dim)
{
int n;
......@@ -647,66 +642,64 @@ gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name =
gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : "");
f->value.function.name
= gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
}
void
gfc_resolve_fdate (gfc_expr * f)
gfc_resolve_fdate (gfc_expr *f)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
f->value.function.name = gfc_get_string (PREFIX("fdate"));
f->value.function.name = gfc_get_string (PREFIX ("fdate"));
}
void
gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
: mpz_get_si (kind->value.integer);
f->value.function.name =
gfc_get_string ("__floor%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->ts.kind = (kind == NULL)
? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__floor%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (n->ts.kind != f->ts.kind)
gfc_convert_type (n, &f->ts, 2);
f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
}
void
gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
......@@ -716,7 +709,7 @@ gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
void
gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("<intrinsic>");
......@@ -724,60 +717,62 @@ gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
void
gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("getcwd"));
f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
}
void
gfc_resolve_getgid (gfc_expr * f)
gfc_resolve_getgid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("getgid"));
f->value.function.name = gfc_get_string (PREFIX ("getgid"));
}
void
gfc_resolve_getpid (gfc_expr * f)
gfc_resolve_getpid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("getpid"));
f->value.function.name = gfc_get_string (PREFIX ("getpid"));
}
void
gfc_resolve_getuid (gfc_expr * f)
gfc_resolve_getuid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("getuid"));
f->value.function.name = gfc_get_string (PREFIX ("getuid"));
}
void
gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
}
void
gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
......@@ -786,7 +781,7 @@ gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
void
gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
......@@ -794,9 +789,8 @@ gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
void
gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
gfc_expr * pos ATTRIBUTE_UNUSED,
gfc_expr * len ATTRIBUTE_UNUSED)
gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
gfc_expr *len ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
......@@ -804,8 +798,7 @@ gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
void
gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
gfc_expr * pos ATTRIBUTE_UNUSED)
gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
......@@ -813,43 +806,42 @@ gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
void
gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}
void
gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_nint (f, a, NULL);
}
void
gfc_resolve_ierrno (gfc_expr * f)
gfc_resolve_ierrno (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
}
void
gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
......@@ -858,17 +850,17 @@ gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
void
gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
......@@ -877,8 +869,8 @@ gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
void
gfc_resolve_index_func (gfc_expr * f, gfc_expr * str,
ATTRIBUTE_UNUSED gfc_expr * sub_str, gfc_expr * back)
gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
{
gfc_typespec ts;
......@@ -894,62 +886,58 @@ gfc_resolve_index_func (gfc_expr * f, gfc_expr * str,
gfc_convert_type (back, &ts, 2);
}
f->value.function.name =
gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
f->value.function.name
= gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
}
void
gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
: mpz_get_si (kind->value.integer);
f->value.function.name =
gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
a->ts.kind);
f->ts.kind = (kind == NULL)
? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__int_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_int2 (gfc_expr * f, gfc_expr * a)
gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 2;
f->value.function.name =
gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
a->ts.kind);
f->value.function.name
= gfc_get_string ("__int_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_int8 (gfc_expr * f, gfc_expr * a)
gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
f->value.function.name =
gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
a->ts.kind);
f->value.function.name
= gfc_get_string ("__int_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_long (gfc_expr * f, gfc_expr * a)
gfc_resolve_long (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name =
gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
a->ts.kind);
f->value.function.name
= gfc_get_string ("__int_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
......@@ -964,65 +952,62 @@ gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
gfc_convert_type (u, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
}
void
gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
f->value.function.name =
gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
f->value.function.name
= gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
}
void
gfc_resolve_rshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
f->value.function.name =
gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
f->value.function.name
= gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
}
void
gfc_resolve_lshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
f->value.function.name =
gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
f->value.function.name
= gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
}
void
gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
gfc_expr * size)
gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
int s_kind;
s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
f->ts = i->ts;
f->value.function.name =
gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
f->value.function.name
= gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
}
void
gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
ATTRIBUTE_UNUSED gfc_expr * s)
gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
gfc_expr *s ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
}
void
gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
gfc_expr * dim)
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char lbound[] = "__lbound";
......@@ -1041,17 +1026,18 @@ gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
void
gfc_resolve_len (gfc_expr * f, gfc_expr * string)
gfc_resolve_len (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__len_%d_i%d", string->ts.kind,
gfc_default_integer_kind);
f->value.function.name
= gfc_get_string ("__len_%d_i%d", string->ts.kind,
gfc_default_integer_kind);
}
void
gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
......@@ -1060,12 +1046,12 @@ gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
void
gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
gfc_expr * p2 ATTRIBUTE_UNUSED)
gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
}
......@@ -1079,39 +1065,40 @@ gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
void
gfc_resolve_log (gfc_expr * f, gfc_expr * x)
gfc_resolve_log (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_LOGICAL;
f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
: mpz_get_si (kind->value.integer);
f->ts.kind = (kind == NULL)
? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
f->rank = a->rank;
f->value.function.name =
gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
{
if (size->ts.kind < gfc_index_integer_kind)
{
......@@ -1124,12 +1111,12 @@ gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_index_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("malloc"));
f->value.function.name = gfc_get_string (PREFIX ("malloc"));
}
void
gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
......@@ -1151,14 +1138,14 @@ gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
f->value.function.name =
gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
f->ts.kind);
}
static void
gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
{
gfc_actual_arglist *a;
......@@ -1168,31 +1155,31 @@ gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
for (a = args->next; a; a = a->next)
{
if (a->expr->ts.kind > f->ts.kind)
f->ts.kind = a->expr->ts.kind;
f->ts.kind = a->expr->ts.kind;
}
/* Convert all parameters to the required kind. */
for (a = args; a; a = a->next)
{
if (a->expr->ts.kind != f->ts.kind)
gfc_convert_type (a->expr, &f->ts, 2);
gfc_convert_type (a->expr, &f->ts, 2);
}
f->value.function.name =
gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
f->value.function.name
= gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
}
void
gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__max_%c%d", f, args);
}
void
gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
const char *name;
int i, j, idim;
......@@ -1217,7 +1204,7 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
......@@ -1244,15 +1231,15 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
else
name = "maxloc";
f->value.function.name =
gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
const char *name;
int i, j, idim;
......@@ -1271,7 +1258,7 @@ gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
......@@ -1298,55 +1285,55 @@ gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
else
name = "maxval";
f->value.function.name =
gfc_get_string (PREFIX("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_mclock (gfc_expr * f)
gfc_resolve_mclock (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = PREFIX("mclock");
f->value.function.name = PREFIX ("mclock");
}
void
gfc_resolve_mclock8 (gfc_expr * f)
gfc_resolve_mclock8 (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
f->value.function.name = PREFIX("mclock8");
f->value.function.name = PREFIX ("mclock8");
}
void
gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
gfc_expr * fsource ATTRIBUTE_UNUSED,
gfc_expr * mask ATTRIBUTE_UNUSED)
gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
if (tsource->ts.type == BT_CHARACTER)
check_charlen_present (tsource);
f->ts = tsource->ts;
f->value.function.name =
gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
tsource->ts.kind);
f->value.function.name
= gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
tsource->ts.kind);
}
void
gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__min_%c%d", f, args);
}
void
gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
const char *name;
int i, j, idim;
......@@ -1371,7 +1358,7 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
......@@ -1398,15 +1385,15 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
else
name = "minloc";
f->value.function.name =
gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
const char *name;
int i, j, idim;
......@@ -1425,7 +1412,7 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
......@@ -1452,14 +1439,14 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
else
name = "minval";
f->value.function.name =
gfc_get_string (PREFIX("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
......@@ -1470,18 +1457,18 @@ gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
gfc_convert_type(p, &a->ts, 2);
gfc_convert_type (p, &a->ts, 2);
else
gfc_convert_type(a, &p->ts, 2);
gfc_convert_type (a, &p->ts, 2);
}
f->value.function.name =
gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
f->value.function.name
= gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
}
void
gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
......@@ -1492,39 +1479,38 @@ gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
gfc_convert_type(p, &a->ts, 2);
gfc_convert_type (p, &a->ts, 2);
else
gfc_convert_type(a, &p->ts, 2);
gfc_convert_type (a, &p->ts, 2);
}
f->value.function.name =
gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
f->ts.kind);
}
void
gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
f->value.function.name =
gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
a->ts.kind);
f->value.function.name
= gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
a->ts.kind);
}
void
gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
: mpz_get_si (kind->value.integer);
f->value.function.name =
gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
f->ts.kind = (kind == NULL)
? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
}
void
gfc_resolve_not (gfc_expr * f, gfc_expr * i)
gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
......@@ -1532,36 +1518,34 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
void
gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
f->ts.kind = gfc_kind_max (i,j);
f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->value.function.name = gfc_get_string ("__or_%c%d",
gfc_type_letter (i->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
void
gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
gfc_expr * vector ATTRIBUTE_UNUSED)
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
gfc_expr *vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX("pack_char")
: PREFIX("pack"));
? PREFIX ("pack_char") : PREFIX ("pack"));
else
{
/* We convert mask to default logical only in the scalar case.
......@@ -1577,15 +1561,14 @@ gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
}
f->value.function.name = (array->ts.type == BT_CHARACTER
? PREFIX("pack_s_char")
: PREFIX("pack_s"));
? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
}
}
void
gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
const char *name;
......@@ -1618,53 +1601,53 @@ gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
else
name = "product";
f->value.function.name =
gfc_get_string (PREFIX("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_REAL;
if (kind != NULL)
f->ts.kind = mpz_get_si (kind->value.integer);
else
f->ts.kind = (a->ts.type == BT_COMPLEX) ?
a->ts.kind : gfc_default_real_kind;
f->ts.kind = (a->ts.type == BT_COMPLEX)
? a->ts.kind : gfc_default_real_kind;
f->value.function.name =
gfc_get_string ("__real_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__real_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_REAL;
f->ts.kind = a->ts.kind;
f->value.function.name =
gfc_get_string ("__real_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__real_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
gfc_expr * p2 ATTRIBUTE_UNUSED)
gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
}
void
gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
gfc_expr * ncopies ATTRIBUTE_UNUSED)
gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
gfc_expr *ncopies ATTRIBUTE_UNUSED)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
......@@ -1673,9 +1656,9 @@ gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
void
gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
gfc_expr * pad ATTRIBUTE_UNUSED,
gfc_expr * order ATTRIBUTE_UNUSED)
gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
gfc_expr *pad ATTRIBUTE_UNUSED,
gfc_expr *order ATTRIBUTE_UNUSED)
{
mpz_t rank;
int kind;
......@@ -1707,19 +1690,19 @@ gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
case 10:
case 16:
if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
f->value.function.name =
gfc_get_string (PREFIX("reshape_%c%d"),
gfc_type_letter (source->ts.type), source->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("reshape_%c%d"),
gfc_type_letter (source->ts.type),
source->ts.kind);
else
f->value.function.name =
gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
f->value.function.name
= gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
break;
default:
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX("reshape_char")
: PREFIX("reshape"));
? PREFIX ("reshape_char") : PREFIX ("reshape"));
break;
}
......@@ -1752,7 +1735,7 @@ gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
void
gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec;
......@@ -1771,7 +1754,7 @@ gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
void
gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
{
f->ts = x->ts;
......@@ -1780,10 +1763,8 @@ gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
......@@ -1792,9 +1773,9 @@ gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
void
gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
gfc_expr * set ATTRIBUTE_UNUSED,
gfc_expr * back ATTRIBUTE_UNUSED)
gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
......@@ -1803,16 +1784,15 @@ gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
void
gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
{
t1->ts = t0->ts;
t1->value.function.name =
gfc_get_string (PREFIX("secnds"));
t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
}
void
gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
{
f->ts = x->ts;
......@@ -1822,10 +1802,8 @@ gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
if (i->ts.kind != 4)
{
gfc_typespec ts;
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
gfc_convert_type_warn (i, &ts, 2, 0);
}
......@@ -1834,28 +1812,28 @@ gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
void
gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->rank = 1;
f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
f->shape = gfc_get_shape (1);
mpz_init_set_ui (f->shape[0], array->rank);
f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
}
void
gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
f->value.function.name =
gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
f->value.function.name
= gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
......@@ -1865,10 +1843,10 @@ gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &f->ts, 2);
f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
}
else
f->value.function.name = gfc_get_string (PREFIX("signal_func"));
f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
if (number->ts.kind != gfc_c_int_kind)
gfc_convert_type (number, &f->ts, 2);
......@@ -1876,25 +1854,25 @@ gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
void
gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec, *tiny, *emin_1;
......@@ -1929,14 +1907,12 @@ gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
prec->next = emin_1;
f->value.function.actual->next = prec;
}
void
gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
gfc_expr * dim,
gfc_expr * ncopies)
gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
gfc_expr *ncopies)
{
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
......@@ -1945,16 +1921,15 @@ gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
f->rank = source->rank + 1;
if (source->rank == 0)
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX("spread_char_scalar")
: PREFIX("spread_scalar"));
? PREFIX ("spread_char_scalar")
: PREFIX ("spread_scalar"));
else
f->value.function.name = (source->ts.type == BT_CHARACTER
? PREFIX("spread_char")
: PREFIX("spread"));
? PREFIX ("spread_char")
: PREFIX ("spread"));
if (dim && gfc_is_constant_expr (dim)
&& ncopies && gfc_is_constant_expr (ncopies)
&& source->shape[0])
&& ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
{
int i, idim;
idim = mpz_get_ui (dim->value.integer);
......@@ -1975,50 +1950,50 @@ gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
void
gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
/* Resolve the g77 compatibility function STAT AND FSTAT. */
void
gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
gfc_expr * a ATTRIBUTE_UNUSED)
gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
}
void
gfc_resolve_lstat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
gfc_expr * a ATTRIBUTE_UNUSED)
gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("lstat_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
}
void
gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (n->ts.kind != f->ts.kind)
gfc_convert_type (n, &f->ts, 2);
f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
}
void
gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
......@@ -2033,21 +2008,21 @@ gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_convert_type (u, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("fgetc"));
f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
}
void
gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
f->value.function.name = gfc_get_string (PREFIX("fget"));
f->value.function.name = gfc_get_string (PREFIX ("fget"));
}
void
gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
......@@ -2062,21 +2037,21 @@ gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_convert_type (u, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("fputc"));
f->value.function.name = gfc_get_string (PREFIX ("fputc"));
}
void
gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
f->value.function.name = gfc_get_string (PREFIX("fput"));
f->value.function.name = gfc_get_string (PREFIX ("fput"));
}
void
gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
......@@ -2091,13 +2066,12 @@ gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
gfc_convert_type (u, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("ftell"));
f->value.function.name = gfc_get_string (PREFIX ("ftell"));
}
void
gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
const char *name;
......@@ -2130,72 +2104,72 @@ gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_resolve_dim_arg (dim);
}
f->value.function.name =
gfc_get_string (PREFIX("%s_%c%d"), name,
f->value.function.name
= gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
gfc_expr * p2 ATTRIBUTE_UNUSED)
gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
}
/* Resolve the g77 compatibility function SYSTEM. */
void
gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("system"));
f->value.function.name = gfc_get_string (PREFIX ("system"));
}
void
gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name =
gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
f->value.function.name
= gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_time (gfc_expr * f)
gfc_resolve_time (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("time_func"));
f->value.function.name = gfc_get_string (PREFIX ("time_func"));
}
void
gfc_resolve_time8 (gfc_expr * f)
gfc_resolve_time8 (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
f->value.function.name = gfc_get_string (PREFIX("time8_func"));
f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
}
void
gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
gfc_expr * mold, gfc_expr * size)
gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
gfc_expr *mold, gfc_expr *size)
{
/* TODO: Make this do something meaningful. */
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
......@@ -2221,7 +2195,7 @@ gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
void
gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
f->ts = matrix->ts;
f->rank = 2;
......@@ -2239,40 +2213,40 @@ gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
case 10:
case 16:
switch (matrix->ts.type)
{
case BT_REAL:
case BT_COMPLEX:
f->value.function.name =
gfc_get_string (PREFIX("transpose_%c%d"),
gfc_type_letter (matrix->ts.type),
matrix->ts.kind);
break;
case BT_INTEGER:
case BT_LOGICAL:
{
case BT_REAL:
case BT_COMPLEX:
f->value.function.name
= gfc_get_string (PREFIX ("transpose_%c%d"),
gfc_type_letter (matrix->ts.type),
matrix->ts.kind);
break;
case BT_INTEGER:
case BT_LOGICAL:
/* Use the integer routines for real and logical cases. This
assumes they all have the same alignment requirements. */
f->value.function.name =
gfc_get_string (PREFIX("transpose_i%d"), matrix->ts.kind);
break;
default:
f->value.function.name = PREFIX("transpose");
break;
}
f->value.function.name
= gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
break;
default:
f->value.function.name = PREFIX ("transpose");
break;
}
break;
default:
f->value.function.name = (matrix->ts.type == BT_CHARACTER
? PREFIX("transpose_char")
: PREFIX("transpose"));
? PREFIX ("transpose_char")
: PREFIX ("transpose"));
break;
}
}
void
gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
......@@ -2281,8 +2255,7 @@ gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
void
gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
gfc_expr * dim)
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char ubound[] = "__ubound";
......@@ -2303,27 +2276,27 @@ gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
/* Resolve the g77 compatibility function UMASK. */
void
gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
{
f->ts.type = BT_INTEGER;
f->ts.kind = n->ts.kind;
f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
}
/* Resolve the g77 compatibility function UNLINK. */
void
gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX("unlink"));
f->value.function.name = gfc_get_string (PREFIX ("unlink"));
}
void
gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
{
gfc_typespec ts;
......@@ -2339,27 +2312,27 @@ gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
gfc_convert_type (unit, &ts, 2);
}
f->value.function.name = gfc_get_string (PREFIX("ttynam"));
f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
}
void
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
gfc_expr *field ATTRIBUTE_UNUSED)
{
f->ts = vector->ts;
f->rank = mask->rank;
f->value.function.name =
gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
vector->ts.type == BT_CHARACTER ? "_char" : "");
f->value.function.name
= gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
vector->ts.type == BT_CHARACTER ? "_char" : "");
}
void
gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
gfc_expr * set ATTRIBUTE_UNUSED,
gfc_expr * back ATTRIBUTE_UNUSED)
gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
gfc_expr *set ATTRIBUTE_UNUSED,
gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
......@@ -2368,29 +2341,28 @@ gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
void
gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
f->ts.kind = gfc_kind_max (i,j);
f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
if (i->ts.kind == gfc_kind_max (i,j))
gfc_convert_type(j, &i->ts, 2);
if (i->ts.kind == gfc_kind_max (i, j))
gfc_convert_type (j, &i->ts, 2);
else
gfc_convert_type(i, &j->ts, 2);
gfc_convert_type (i, &j->ts, 2);
}
f->value.function.name = gfc_get_string ("__xor_%c%d",
gfc_type_letter (i->ts.type),
f->ts.kind);
f->value.function.name
= gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
/* Intrinsic subroutine resolution. */
void
gfc_resolve_alarm_sub (gfc_code * c)
gfc_resolve_alarm_sub (gfc_code *c)
{
const char *name;
gfc_expr *seconds, *handler, *status;
......@@ -2407,10 +2379,10 @@ gfc_resolve_alarm_sub (gfc_code * c)
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
name = gfc_get_string (PREFIX("alarm_sub_int"));
name = gfc_get_string (PREFIX ("alarm_sub_int"));
}
else
name = gfc_get_string (PREFIX("alarm_sub"));
name = gfc_get_string (PREFIX ("alarm_sub"));
if (seconds->ts.kind != gfc_c_int_kind)
gfc_convert_type (seconds, &ts, 2);
......@@ -2421,47 +2393,43 @@ gfc_resolve_alarm_sub (gfc_code * c)
}
void
gfc_resolve_cpu_time (gfc_code * c)
gfc_resolve_cpu_time (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("cpu_time_%d"),
c->ext.actual->expr->ts.kind);
name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_mvbits (gfc_code * c)
gfc_resolve_mvbits (gfc_code *c)
{
const char *name;
int kind;
kind = c->ext.actual->expr->ts.kind;
name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_random_number (gfc_code * c)
gfc_resolve_random_number (gfc_code *c)
{
const char *name;
int kind;
kind = c->ext.actual->expr->ts.kind;
if (c->ext.actual->expr->rank == 0)
name = gfc_get_string (PREFIX("random_r%d"), kind);
name = gfc_get_string (PREFIX ("random_r%d"), kind);
else
name = gfc_get_string (PREFIX("arandom_r%d"), kind);
name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_rename_sub (gfc_code * c)
gfc_resolve_rename_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2471,13 +2439,13 @@ gfc_resolve_rename_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_kill_sub (gfc_code * c)
gfc_resolve_kill_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2487,13 +2455,13 @@ gfc_resolve_kill_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_link_sub (gfc_code * c)
gfc_resolve_link_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2503,13 +2471,13 @@ gfc_resolve_link_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_symlnk_sub (gfc_code * c)
gfc_resolve_symlnk_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2519,7 +2487,7 @@ gfc_resolve_symlnk_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2527,11 +2495,10 @@ gfc_resolve_symlnk_sub (gfc_code * c)
/* G77 compatibility subroutines etime() and dtime(). */
void
gfc_resolve_etime_sub (gfc_code * c)
gfc_resolve_etime_sub (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("etime_sub"));
name = gfc_get_string (PREFIX ("etime_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2539,52 +2506,51 @@ gfc_resolve_etime_sub (gfc_code * c)
/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
void
gfc_resolve_itime (gfc_code * c)
gfc_resolve_itime (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol
(gfc_get_string (PREFIX("itime_i%d"),
gfc_default_integer_kind));
c->resolved_sym
= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
gfc_default_integer_kind));
}
void
gfc_resolve_idate (gfc_code * c)
gfc_resolve_idate (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol
(gfc_get_string (PREFIX("idate_i%d"),
gfc_default_integer_kind));
c->resolved_sym
= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
gfc_default_integer_kind));
}
void
gfc_resolve_ltime (gfc_code * c)
gfc_resolve_ltime (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol
(gfc_get_string (PREFIX("ltime_i%d"),
gfc_default_integer_kind));
c->resolved_sym
= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
gfc_default_integer_kind));
}
void
gfc_resolve_gmtime (gfc_code * c)
gfc_resolve_gmtime (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol
(gfc_get_string (PREFIX("gmtime_i%d"),
gfc_default_integer_kind));
c->resolved_sym
= gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
gfc_default_integer_kind));
}
/* G77 compatibility subroutine second(). */
void
gfc_resolve_second_sub (gfc_code * c)
gfc_resolve_second_sub (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("second_sub"));
name = gfc_get_string (PREFIX ("second_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_sleep_sub (gfc_code * c)
gfc_resolve_sleep_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2594,7 +2560,7 @@ gfc_resolve_sleep_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2602,10 +2568,10 @@ gfc_resolve_sleep_sub (gfc_code * c)
/* G77 compatibility function srand(). */
void
gfc_resolve_srand (gfc_code * c)
gfc_resolve_srand (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("srand"));
name = gfc_get_string (PREFIX ("srand"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2613,20 +2579,20 @@ gfc_resolve_srand (gfc_code * c)
/* Resolve the getarg intrinsic subroutine. */
void
gfc_resolve_getarg (gfc_code * c)
gfc_resolve_getarg (gfc_code *c)
{
const char *name;
int kind;
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("getarg_i%d"), kind);
name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the getcwd intrinsic subroutine. */
void
gfc_resolve_getcwd_sub (gfc_code * c)
gfc_resolve_getcwd_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2636,7 +2602,7 @@ gfc_resolve_getcwd_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2644,13 +2610,12 @@ gfc_resolve_getcwd_sub (gfc_code * c)
/* Resolve the get_command intrinsic subroutine. */
void
gfc_resolve_get_command (gfc_code * c)
gfc_resolve_get_command (gfc_code *c)
{
const char *name;
int kind;
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("get_command_i%d"), kind);
name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
......@@ -2658,31 +2623,31 @@ gfc_resolve_get_command (gfc_code * c)
/* Resolve the get_command_argument intrinsic subroutine. */
void
gfc_resolve_get_command_argument (gfc_code * c)
gfc_resolve_get_command_argument (gfc_code *c)
{
const char *name;
int kind;
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the get_environment_variable intrinsic subroutine. */
void
gfc_resolve_get_environment_variable (gfc_code * code)
gfc_resolve_get_environment_variable (gfc_code *code)
{
const char *name;
int kind;
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_signal_sub (gfc_code * c)
gfc_resolve_signal_sub (gfc_code *c)
{
const char *name;
gfc_expr *number, *handler, *status;
......@@ -2699,10 +2664,10 @@ gfc_resolve_signal_sub (gfc_code * c)
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
name = gfc_get_string (PREFIX("signal_sub_int"));
name = gfc_get_string (PREFIX ("signal_sub_int"));
}
else
name = gfc_get_string (PREFIX("signal_sub"));
name = gfc_get_string (PREFIX ("signal_sub"));
if (number->ts.kind != gfc_c_int_kind)
gfc_convert_type (number, &ts, 2);
......@@ -2712,21 +2677,22 @@ gfc_resolve_signal_sub (gfc_code * c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the SYSTEM intrinsic subroutine. */
void
gfc_resolve_system_sub (gfc_code * c)
gfc_resolve_system_sub (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("system_sub"));
name = gfc_get_string (PREFIX ("system_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
void
gfc_resolve_system_clock (gfc_code * c)
gfc_resolve_system_clock (gfc_code *c)
{
const char *name;
int kind;
......@@ -2740,14 +2706,15 @@ gfc_resolve_system_clock (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("system_clock_%d"), kind);
name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the EXIT intrinsic subroutine. */
void
gfc_resolve_exit (gfc_code * c)
gfc_resolve_exit (gfc_code *c)
{
const char *name;
int kind;
......@@ -2757,14 +2724,15 @@ gfc_resolve_exit (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("exit_i%d"), kind);
name = gfc_get_string (PREFIX ("exit_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the FLUSH intrinsic subroutine. */
void
gfc_resolve_flush (gfc_code * c)
gfc_resolve_flush (gfc_code *c)
{
const char *name;
gfc_typespec ts;
......@@ -2773,17 +2741,16 @@ gfc_resolve_flush (gfc_code * c)
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
n = c->ext.actual->expr;
if (n != NULL
&& n->ts.kind != ts.kind)
if (n != NULL && n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_free (gfc_code * c)
gfc_resolve_free (gfc_code *c)
{
gfc_typespec ts;
gfc_expr *n;
......@@ -2794,12 +2761,12 @@ gfc_resolve_free (gfc_code * c)
if (n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
}
void
gfc_resolve_ctime_sub (gfc_code * c)
gfc_resolve_ctime_sub (gfc_code *c)
{
gfc_typespec ts;
......@@ -2813,33 +2780,33 @@ gfc_resolve_ctime_sub (gfc_code * c)
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
}
void
gfc_resolve_fdate_sub (gfc_code * c)
gfc_resolve_fdate_sub (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
}
void
gfc_resolve_gerror (gfc_code * c)
gfc_resolve_gerror (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
}
void
gfc_resolve_getlog (gfc_code * c)
gfc_resolve_getlog (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
}
void
gfc_resolve_hostnm_sub (gfc_code * c)
gfc_resolve_hostnm_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -2849,13 +2816,13 @@ gfc_resolve_hostnm_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_perror (gfc_code * c)
gfc_resolve_perror (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
}
......@@ -2863,27 +2830,25 @@ gfc_resolve_perror (gfc_code * c)
/* Resolve the STAT and FSTAT intrinsic subroutines. */
void
gfc_resolve_stat_sub (gfc_code * c)
gfc_resolve_stat_sub (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_lstat_sub (gfc_code * c)
gfc_resolve_lstat_sub (gfc_code *c)
{
const char *name;
name = gfc_get_string (PREFIX("lstat_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_fstat_sub (gfc_code * c)
gfc_resolve_fstat_sub (gfc_code *c)
{
const char *name;
gfc_expr *u;
......@@ -2893,13 +2858,13 @@ gfc_resolve_fstat_sub (gfc_code * c)
ts = &c->ext.actual->next->expr->ts;
if (u->ts.kind != ts->kind)
gfc_convert_type (u, ts, 2);
name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_fgetc_sub (gfc_code * c)
gfc_resolve_fgetc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
......@@ -2918,32 +2883,32 @@ gfc_resolve_fgetc_sub (gfc_code * c)
}
if (st != NULL)
name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
else
name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_fget_sub (gfc_code * c)
gfc_resolve_fget_sub (gfc_code *c)
{
const char *name;
gfc_expr *st;
st = c->ext.actual->next->expr;
if (st != NULL)
name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
else
name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_fputc_sub (gfc_code * c)
gfc_resolve_fputc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
......@@ -2962,32 +2927,32 @@ gfc_resolve_fputc_sub (gfc_code * c)
}
if (st != NULL)
name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
else
name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_fput_sub (gfc_code * c)
gfc_resolve_fput_sub (gfc_code *c)
{
const char *name;
gfc_expr *st;
st = c->ext.actual->next->expr;
if (st != NULL)
name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
else
name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_ftell_sub (gfc_code * c)
gfc_resolve_ftell_sub (gfc_code *c)
{
const char *name;
gfc_expr *unit;
......@@ -3006,13 +2971,13 @@ gfc_resolve_ftell_sub (gfc_code * c)
gfc_convert_type (unit, &ts, 2);
}
name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_ttynam_sub (gfc_code * c)
gfc_resolve_ttynam_sub (gfc_code *c)
{
gfc_typespec ts;
......@@ -3025,14 +2990,14 @@ gfc_resolve_ttynam_sub (gfc_code * c)
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
}
/* Resolve the UMASK intrinsic subroutine. */
void
gfc_resolve_umask_sub (gfc_code * c)
gfc_resolve_umask_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -3042,14 +3007,14 @@ gfc_resolve_umask_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the UNLINK intrinsic subroutine. */
void
gfc_resolve_unlink_sub (gfc_code * c)
gfc_resolve_unlink_sub (gfc_code *c)
{
const char *name;
int kind;
......@@ -3059,6 +3024,6 @@ gfc_resolve_unlink_sub (gfc_code * c)
else
kind = gfc_default_integer_kind;
name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
gcc/fortran/match.c
/* Matching subroutines in all sizes, shapes and colors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
......@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
......@@ -225,7 +224,7 @@ gfc_match_small_int (int *value)
do most of the work. */
match
gfc_match_st_label (gfc_st_label ** label)
gfc_match_st_label (gfc_st_label **label)
{
locus old_loc;
match m;
......@@ -314,7 +313,7 @@ gfc_match_label (void)
A '%' character is a mandatory space. */
int
gfc_match_strings (mstring * a)
gfc_match_strings (mstring *a)
{
mstring *p, *best_match;
int no_match, c, possibles;
......@@ -348,8 +347,7 @@ gfc_match_strings (mstring * a)
if (*p->mp == ' ')
{
/* Space matches 1+ whitespace(s). */
if ((gfc_current_form == FORM_FREE)
&& gfc_is_whitespace (c))
if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
continue;
p->mp++;
......@@ -397,7 +395,7 @@ gfc_match_name (char *buffer)
if (!ISALPHA (c))
{
if (gfc_error_flag_test() == 0)
gfc_error ("Invalid character in name at %C");
gfc_error ("Invalid character in name at %C");
gfc_current_locus = old_loc;
return MATCH_NO;
}
......@@ -417,9 +415,7 @@ gfc_match_name (char *buffer)
old_loc = gfc_current_locus;
c = gfc_next_char ();
}
while (ISALNUM (c)
|| c == '_'
|| (gfc_option.flag_dollar_ok && c == '$'));
while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
gfc_current_locus = old_loc;
......@@ -432,7 +428,7 @@ gfc_match_name (char *buffer)
pointer if successful. */
match
gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
......@@ -443,7 +439,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
if (host_assoc)
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
? MATCH_ERROR : MATCH_YES;
? MATCH_ERROR : MATCH_YES;
if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
return MATCH_ERROR;
......@@ -453,7 +449,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
match
gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
{
gfc_symtree *st;
match m;
......@@ -463,21 +459,22 @@ gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
if (m == MATCH_YES)
{
if (st)
*matched_symbol = st->n.sym;
*matched_symbol = st->n.sym;
else
*matched_symbol = NULL;
*matched_symbol = NULL;
}
else
*matched_symbol = NULL;
return m;
}
/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
in matchexp.c. */
match
gfc_match_intrinsic_op (gfc_intrinsic_op * result)
gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
gfc_intrinsic_op op;
......@@ -500,15 +497,14 @@ gfc_match_intrinsic_op (gfc_intrinsic_op * result)
the equals sign is seen. */
match
gfc_match_iterator (gfc_iterator * iter, int init_flag)
gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
/* Match the start of an iterator without affecting the symbol
table. */
/* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
m = gfc_match (" %n =", name);
......@@ -784,7 +780,7 @@ not_yes:
case 'l':
case 'n':
case 's':
(void)va_arg (argp, void **);
(void) va_arg (argp, void **);
break;
case 'e':
......@@ -936,6 +932,7 @@ cleanup:
when just after having encountered a simple IF statement. This code
is really duplicate with parts of the gfc_match_if code, but this is
*much* easier. */
static match
match_arithmetic_if (void)
{
......@@ -955,8 +952,8 @@ match_arithmetic_if (void)
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: arithmetic IF statement at %C") == FAILURE)
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF statement "
"at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
......@@ -983,7 +980,7 @@ static match match_simple_forall (void);
static match match_simple_where (void);
match
gfc_match_if (gfc_statement * if_type)
gfc_match_if (gfc_statement *if_type)
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
......@@ -1014,10 +1011,8 @@ gfc_match_if (gfc_statement * if_type)
{
if (n == MATCH_YES)
{
gfc_error
("Block label not appropriate for arithmetic IF statement "
"at %C");
gfc_error ("Block label not appropriate for arithmetic IF "
"statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
......@@ -1026,15 +1021,13 @@ gfc_match_if (gfc_statement * if_type)
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: arithmetic IF statement at %C")
== FAILURE)
return MATCH_ERROR;
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF "
"statement at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
......@@ -1050,7 +1043,6 @@ gfc_match_if (gfc_statement * if_type)
{
new_st.op = EXEC_IF;
new_st.expr = expr;
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
......@@ -1058,7 +1050,6 @@ gfc_match_if (gfc_statement * if_type)
if (n == MATCH_YES)
{
gfc_error ("Block label is not appropriate IF statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
......@@ -1146,7 +1137,7 @@ gfc_match_if (gfc_statement * if_type)
/* All else has failed, so give up. See if any of the matchers has
stored an error message of some sort. */
if (gfc_error_check () == 0)
if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
......@@ -1258,9 +1249,8 @@ cleanup:
/* Free a gfc_iterator structure. */
void
gfc_free_iterator (gfc_iterator * iter, int flag)
gfc_free_iterator (gfc_iterator *iter, int flag)
{
if (iter == NULL)
return;
......@@ -1310,8 +1300,7 @@ gfc_match_do (void)
}
/* match an optional comma, if no comma is found a space is obligatory. */
if (gfc_match_char(',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES)
if (gfc_match_char(',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
return MATCH_NO;
/* See if we have a DO WHILE. */
......@@ -1456,7 +1445,6 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
match
gfc_match_exit (void)
{
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
......@@ -1466,7 +1454,6 @@ gfc_match_exit (void)
match
gfc_match_cycle (void)
{
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
......@@ -1488,7 +1475,7 @@ gfc_match_stopcode (gfc_statement st)
{
m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
goto cleanup;
goto cleanup;
if (m == MATCH_YES && cnt > 5)
{
......@@ -1497,25 +1484,25 @@ gfc_match_stopcode (gfc_statement st)
}
if (m == MATCH_NO)
{
/* Try a character constant. */
m = gfc_match_expr (&e);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
goto syntax;
}
{
/* Try a character constant. */
m = gfc_match_expr (&e);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
goto syntax;
}
if (gfc_match_eos () != MATCH_YES)
goto syntax;
goto syntax;
}
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
gfc_ascii_statement (st));
gfc_ascii_statement (st));
goto cleanup;
}
......@@ -1544,8 +1531,7 @@ gfc_match_pause (void)
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: PAUSE statement at %C")
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C")
== FAILURE)
m = MATCH_ERROR;
}
......@@ -1567,7 +1553,6 @@ gfc_match_stop (void)
match
gfc_match_continue (void)
{
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
......@@ -1590,21 +1575,21 @@ gfc_match_assign (void)
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
return MATCH_ERROR;
return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: ASSIGN statement at %C")
{
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN "
"statement at %C")
== FAILURE)
return MATCH_ERROR;
expr->symtree->n.sym->attr.assign = 1;
expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_LABEL_ASSIGN;
new_st.label = label;
new_st.expr = expr;
return MATCH_YES;
}
new_st.op = EXEC_LABEL_ASSIGN;
new_st.label = label;
new_st.expr = expr;
return MATCH_YES;
}
}
return MATCH_NO;
}
......@@ -1639,8 +1624,8 @@ gfc_match_goto (void)
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: Assigned GOTO statement at %C")
if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO "
"statement at %C")
== FAILURE)
return MATCH_ERROR;
......@@ -1686,8 +1671,7 @@ gfc_match_goto (void)
if (head == NULL)
{
gfc_error (
"Statement label list in GOTO at %C cannot be empty");
gfc_error ("Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
new_st.block = head;
......@@ -1773,7 +1757,7 @@ cleanup:
/* Frees a list of gfc_alloc structures. */
void
gfc_free_alloc_list (gfc_alloc * p)
gfc_free_alloc_list (gfc_alloc *p)
{
gfc_alloc *q;
......@@ -1821,7 +1805,7 @@ gfc_match_allocate (void)
goto cleanup;
if (gfc_pure (NULL)
&& gfc_impure_variable (tail->expr->symtree->n.sym))
&& gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
"PURE procedure");
......@@ -1845,23 +1829,21 @@ gfc_match_allocate (void)
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error
("STAT variable '%s' of ALLOCATE statement at %C cannot be "
"INTENT(IN)", stat->symtree->n.sym->name);
gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
"be INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
gfc_error
("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
"procedure");
gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
"for a PURE procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
gfc_error("STAT expression at %C must be a variable");
gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
......@@ -1915,8 +1897,7 @@ gfc_match_nullify (void)
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
gfc_error
("Illegal variable in NULLIFY at %C for a PURE procedure");
gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
......@@ -1991,11 +1972,10 @@ gfc_match_deallocate (void)
goto cleanup;
if (gfc_pure (NULL)
&& gfc_impure_variable (tail->expr->symtree->n.sym))
&& gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error
("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
"procedure");
gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
"for a PURE procedure");
goto cleanup;
}
......@@ -2027,7 +2007,7 @@ gfc_match_deallocate (void)
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
gfc_error("STAT expression at %C must be a variable");
gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
......@@ -2077,12 +2057,12 @@ gfc_match_return (void)
if (gfc_current_form == FORM_FREE)
{
/* The following are valid, so we can't require a blank after the
RETURN keyword:
return+1
return(1) */
RETURN keyword:
return+1
return(1) */
c = gfc_peek_char ();
if (ISALPHA (c) || ISDIGIT (c))
return MATCH_NO;
return MATCH_NO;
}
m = gfc_match (" %e%t", &e);
......@@ -2101,7 +2081,7 @@ done:
gfc_enclosing_unit (&s);
if (s == COMP_PROGRAM
&& gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
"main program at %C") == FAILURE)
"main program at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
......@@ -2177,7 +2157,7 @@ gfc_match_call (void)
new_st.next = c = gfc_get_code ();
c->op = EXEC_SELECT;
sprintf (name, "_result_%s",sym->name);
sprintf (name, "_result_%s", sym->name);
gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
select_sym = select_st->n.sym;
......@@ -2241,13 +2221,13 @@ gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
static int serial = 0;
char mangled_name[GFC_MAX_SYMBOL_LEN+1];
char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
if (from_module)
{
/* A use associated common block is only needed to correctly layout
the variables it contains. */
snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
......@@ -2306,10 +2286,10 @@ match
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
char name[GFC_MAX_SYMBOL_LEN+1];
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *t;
gfc_array_spec *as;
gfc_equiv * e1, * e2;
gfc_equiv *e1, *e2;
match m;
gfc_gsymbol *gsym;
......@@ -2331,8 +2311,8 @@ gfc_match_common (void)
gsym = gfc_get_gsymbol (name);
if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
{
gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
name);
gfc_error ("Symbol '%s' at %C is already an external symbol that "
"is not COMMON", name);
goto cleanup;
}
......@@ -2349,7 +2329,8 @@ gfc_match_common (void)
{
if (gfc_current_ns->is_block_data)
{
gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C");
gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
"at %C");
}
t = &gfc_current_ns->blank_common;
if (t->head == NULL)
......@@ -2407,9 +2388,8 @@ gfc_match_common (void)
/* Derived type names must have the SEQUENCE attribute. */
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
{
gfc_error
("Derived type variable in COMMON at %C does not have the "
"SEQUENCE attribute");
gfc_error ("Derived type variable in COMMON at %C does not "
"have the SEQUENCE attribute");
goto cleanup;
}
......@@ -2421,7 +2401,7 @@ gfc_match_common (void)
tail = sym;
/* Deal with an optional array specification after the
symbol name. */
symbol name. */
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
......@@ -2430,9 +2410,8 @@ gfc_match_common (void)
{
if (as->type != AS_EXPLICIT)
{
gfc_error
("Array specification for symbol '%s' in COMMON at %C "
"must be explicit", sym->name);
gfc_error ("Array specification for symbol '%s' in COMMON "
"at %C must be explicit", sym->name);
goto cleanup;
}
......@@ -2441,9 +2420,8 @@ gfc_match_common (void)
if (sym->attr.pointer)
{
gfc_error
("Symbol '%s' in COMMON at %C cannot be a POINTER array",
sym->name);
gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
"POINTER array", sym->name);
goto cleanup;
}
......@@ -2459,9 +2437,9 @@ gfc_match_common (void)
if (sym->attr.in_equivalence)
{
for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
{
for (e2 = e1; e2; e2 = e2->eq)
if (e2->expr->symtree->n.sym == sym)
{
for (e2 = e1; e2; e2 = e2->eq)
if (e2->expr->symtree->n.sym == sym)
goto equiv_found;
continue;
......@@ -2472,13 +2450,12 @@ gfc_match_common (void)
{
other = e2->expr->symtree->n.sym;
if (other->common_head
&& other->common_head != sym->common_head)
&& other->common_head != sym->common_head)
{
gfc_error ("Symbol '%s', in COMMON block '%s' at "
"%C is being indirectly equivalenced to "
"another COMMON block '%s'",
sym->name,
sym->common_head->name,
sym->name, sym->common_head->name,
other->common_head->name);
goto cleanup;
}
......@@ -2552,7 +2529,7 @@ gfc_match_block_data (void)
/* Free a namelist structure. */
void
gfc_free_namelist (gfc_namelist * name)
gfc_free_namelist (gfc_namelist *name)
{
gfc_namelist *n;
......@@ -2583,9 +2560,9 @@ gfc_match_namelist (void)
{
if (group_name->ts.type != BT_UNKNOWN)
{
gfc_error
("Namelist group name '%s' at %C already has a basic type "
"of %s", group_name->name, gfc_typename (&group_name->ts));
gfc_error ("Namelist group name '%s' at %C already has a basic "
"type of %s", group_name->name,
gfc_typename (&group_name->ts));
return MATCH_ERROR;
}
......@@ -2594,7 +2571,7 @@ gfc_match_namelist (void)
&& gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name)
== FAILURE)
== FAILURE)
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
......@@ -2619,14 +2596,14 @@ gfc_match_namelist (void)
if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Assumed size array '%s' in namelist '%s' at "
"%C is not allowed", sym->name, group_name->name);
"%C is not allowed", sym->name, group_name->name);
gfc_error_check ();
}
if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
&& gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
"namelist '%s' at %C is an extension.",
sym->name, group_name->name) == FAILURE)
&& gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
"namelist '%s' at %C is an extension.",
sym->name, group_name->name) == FAILURE)
gfc_error_check ();
nl = gfc_get_namelist ();
......@@ -2695,15 +2672,13 @@ gfc_match_module (void)
do this. */
void
gfc_free_equiv (gfc_equiv * eq)
gfc_free_equiv (gfc_equiv *eq)
{
if (eq == NULL)
return;
gfc_free_equiv (eq->eq);
gfc_free_equiv (eq->next);
gfc_free_expr (eq->expr);
gfc_free (eq);
}
......@@ -2761,16 +2736,14 @@ gfc_match_equivalence (void)
for (ref = set->expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
{
gfc_error
("Array reference in EQUIVALENCE at %C cannot be an "
"array section");
gfc_error ("Array reference in EQUIVALENCE at %C cannot "
"be an array section");
goto cleanup;
}
sym = set->expr->symtree->n.sym;
if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
== FAILURE)
if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.in_common)
......@@ -2807,8 +2780,7 @@ gfc_match_equivalence (void)
{
gfc_error ("Attempt to indirectly overlap COMMON "
"blocks %s and %s by EQUIVALENCE at %C",
sym->common_head->name,
common_head->name);
sym->common_head->name, common_head->name);
goto cleanup;
}
sym->attr.in_common = 1;
......@@ -2836,6 +2808,7 @@ cleanup:
return MATCH_ERROR;
}
/* Check that a statement function is not recursive. This is done by looking
for the statement function symbol(sym) by looking recursively through its
expression(e). If a reference to sym is found, true is returned.
......@@ -2858,8 +2831,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
{
if (sym->name == arg->name
|| recursive_stmt_fcn (arg->expr, sym))
if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
return true;
}
......@@ -2872,8 +2844,8 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
/* Catch recursion via other statement functions. */
if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
&& e->symtree->n.sym->value
&& recursive_stmt_fcn (e->symtree->n.sym->value, sym))
&& e->symtree->n.sym->value
&& recursive_stmt_fcn (e->symtree->n.sym->value, sym))
return true;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
......@@ -2891,7 +2863,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
case EXPR_OP:
if (recursive_stmt_fcn (e->value.op.op1, sym)
|| recursive_stmt_fcn (e->value.op.op2, sym))
|| recursive_stmt_fcn (e->value.op.op2, sym))
return true;
break;
......@@ -2910,15 +2882,15 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
for (i = 0; i < ref->u.ar.dimen; i++)
{
if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
|| recursive_stmt_fcn (ref->u.ar.end[i], sym)
|| recursive_stmt_fcn (ref->u.ar.stride[i], sym))
|| recursive_stmt_fcn (ref->u.ar.end[i], sym)
|| recursive_stmt_fcn (ref->u.ar.stride[i], sym))
return true;
}
break;
case REF_SUBSTRING:
if (recursive_stmt_fcn (ref->u.ss.start, sym)
|| recursive_stmt_fcn (ref->u.ss.end, sym))
|| recursive_stmt_fcn (ref->u.ss.end, sym))
return true;
break;
......@@ -2967,8 +2939,7 @@ gfc_match_st_function (void)
if (recursive_stmt_fcn (expr, sym))
{
gfc_error ("Statement function at %L is recursive",
&expr->where);
gfc_error ("Statement function at %L is recursive", &expr->where);
return MATCH_ERROR;
}
......@@ -2987,7 +2958,7 @@ undo_error:
/* Free a single case structure. */
static void
free_case (gfc_case * p)
free_case (gfc_case *p)
{
if (p->low == p->high)
p->high = NULL;
......@@ -3000,7 +2971,7 @@ free_case (gfc_case * p)
/* Free a list of case structures. */
void
gfc_free_case_list (gfc_case * p)
gfc_free_case_list (gfc_case *p)
{
gfc_case *q;
......@@ -3015,7 +2986,7 @@ gfc_free_case_list (gfc_case * p)
/* Match a single case selector. */
static match
match_case_selector (gfc_case ** cp)
match_case_selector (gfc_case **cp)
{
gfc_case *c;
match m;
......@@ -3031,7 +3002,6 @@ match_case_selector (gfc_case ** cp)
if (m == MATCH_ERROR)
goto cleanup;
}
else
{
m = gfc_match_init_expr (&c->low);
......@@ -3245,7 +3215,7 @@ cleanup:
/* Match a WHERE statement. */
match
gfc_match_where (gfc_statement * st)
gfc_match_where (gfc_statement *st)
{
gfc_expr *expr;
match m0, m;
......@@ -3262,7 +3232,6 @@ gfc_match_where (gfc_statement * st)
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
......@@ -3363,19 +3332,17 @@ cleanup:
/* Free a list of FORALL iterators. */
void
gfc_free_forall_iterator (gfc_forall_iterator * iter)
gfc_free_forall_iterator (gfc_forall_iterator *iter)
{
gfc_forall_iterator *next;
while (iter)
{
next = iter->next;
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->stride);
gfc_free (iter);
iter = next;
}
......@@ -3387,7 +3354,7 @@ gfc_free_forall_iterator (gfc_forall_iterator * iter)
<var> = <start>:<end>[:<stride>][, <scalar mask>] */
static match
match_forall_iterator (gfc_forall_iterator ** result)
match_forall_iterator (gfc_forall_iterator **result)
{
gfc_forall_iterator *iter;
locus where;
......@@ -3444,8 +3411,8 @@ cleanup:
/* Make sure that potential internal function references in the
mask do not get messed up. */
if (iter->var
&& iter->var->expr_type == EXPR_VARIABLE
&& iter->var->symtree->n.sym->refs == 1)
&& iter->var->expr_type == EXPR_VARIABLE
&& iter->var->symtree->n.sym->refs == 1)
iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
gfc_current_locus = where;
......@@ -3457,7 +3424,7 @@ cleanup:
/* Match the header of a FORALL statement. */
static match
match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
gfc_forall_iterator *head, *tail, *new;
gfc_expr *msk;
......@@ -3523,8 +3490,8 @@ cleanup:
return MATCH_ERROR;
}
/* Match the rest of a simple FORALL statement that follows an IF statement.
*/
/* Match the rest of a simple FORALL statement that follows an
IF statement. */
static match
match_simple_forall (void)
......@@ -3590,7 +3557,7 @@ cleanup:
/* Match a FORALL statement. */
match
gfc_match_forall (gfc_statement * st)
gfc_match_forall (gfc_statement *st)
{
gfc_forall_iterator *head;
gfc_expr *mask;
......@@ -3618,11 +3585,9 @@ gfc_match_forall (gfc_statement * st)
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_FORALL_BLOCK;
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
return MATCH_YES;
}
......@@ -3647,7 +3612,6 @@ gfc_match_forall (gfc_statement * st)
new_st.expr = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
new_st.block->op = EXEC_FORALL;
new_st.block->next = c;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment