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