+2007-01-08 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ * interface.c, intrinsic.c, gfortranspec.c, io.c, f95-lang.c,
+ iresolve.c, match.c: Update Copyright years. Whitespace.
+
+
2007-01-08 Richard Guenther <rguenther@suse.de>
* trans-io.c (transfer_array_desc): Use build_int_cst instead
/* gfortran backend interface
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Paul Brook.
tree_rest_of_compilation (fndecl);
}
-\f
+
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
or validate its data type for an `if' or `while' statement or ?..: exp.
return expr;
}
else if (TREE_CODE (expr) == NOP_EXPR)
- return build1 (NOP_EXPR, boolean_type_node,
- TREE_OPERAND (expr, 0));
+ return build1 (NOP_EXPR, boolean_type_node, TREE_OPERAND (expr, 0));
else
return build1 (NOP_EXPR, boolean_type_node, expr);
}
}
+
static void
gfc_create_decls (void)
{
gfc_init_constants ();
}
+
static void
gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
errorcount += errors;
warningcount += warnings;
}
-\f
+
+
/* Initialize everything. */
static bool
{
return;
}
-\f
+
/* These functions and variables deal with binding contours. We only
need these functions for the list of PARM_DECLs, but we leave the
functions more general; these are a simplified version of the
functions from GNAT. */
-/* For each binding contour we allocate a binding_level structure which records
- the entities defined or declared in that contour. Contours include:
+/* For each binding contour we allocate a binding_level structure which
+ records the entities defined or declared in that contour. Contours
+ include:
the global one
one for each subprogram definition
/* Binding level structures are initialized by copying this one. */
static struct binding_level clear_binding_level = { NULL, NULL, NULL };
-\f
+
+
/* Return nonzero if we are currently in the global binding level. */
int
reverse order except for PARM_DECL node, which are explicitly stored in
the right order. */
decl_chain = (reverse) ? nreverse (current_binding_level->names)
- : current_binding_level->names;
+ : current_binding_level->names;
/* If there were any declarations in the current binding level, or if this
binding level is a function body, or if there are any nested blocks then
return block_node;
}
-\f
+
+
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
to handle the BLOCK node inside the BIND_EXPR. */
= chainon (current_binding_level->blocks, block);
}
+
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
gfc_init_types ();
}
+
/* Mark EXP saying that we need to be able to take the
address of it; it should not be allocated in a register.
In Fortran 95 this is only the case for variables with
likely future Cray pointer extension.
Value is 1 if successful. */
/* TODO: Check/fix mark_addressable. */
+
bool
gfc_mark_addressable (tree exp)
{
{
if (TREE_PUBLIC (x))
{
- error
- ("global register variable %qs used in nested function",
- IDENTIFIER_POINTER (DECL_NAME (x)));
+ error ("global register variable %qs used in nested function",
+ IDENTIFIER_POINTER (DECL_NAME (x)));
return false;
}
pedwarn ("register variable %qs used in nested function",
}
}
+
/* 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. */
return -1;
}
+
/* press the big red button - garbage (ggc) collection is on */
int ggc_p = 1;
static void
-gfc_define_builtin (const char * name,
+gfc_define_builtin (const char *name,
tree type,
int code,
- const char * library_name,
+ const char *library_name,
bool const_p)
{
tree decl;
/* Create function types for builtin functions. */
static void
-build_builtin_fntypes (tree * fntype, tree type)
+build_builtin_fntypes (tree *fntype, tree type)
{
tree tmp;
fntype[2] = build_function_type (type, tmp);
}
+
static tree
builtin_type_for_size (int size, bool unsignedp)
{
/* Specific flags and argument handling of the Fortran front-end.
- Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
This file is part of GCC.
along with GNU CC; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
+
/* This file is copied more or less verbatim from g77. */
/* This file contains a filter for the main `gcc' driver, which is
replicated for the `gfortran' driver by adding this filter. The purpose
opt = OPTION_x, arg = text + 2;
else
{
- if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */
+ if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */
;
else if (!strcmp (text, "-fhelp")) /* Really --help!! */
opt = OPTION_help;
case OPTION_version:
printf ("GNU Fortran 95 (GCC) %s\n", version_string);
printf ("Copyright %s 2006 Free Software Foundation, Inc.\n\n",
- _("(C)"));
+ _("(C)"));
printf (_("GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\
You may redistribute copies of GNU Fortran\n\
under the terms of the GNU General Public License.\n\
}
/* This is the one place we check for missing arguments in the
- program. */
+ program. */
if (i + skip < argc)
i += skip;
}
if ((argv[i][0] == '-') && (argv[i][1] == 'M'))
- {
- char *p;
-
- if (argv[i][2] == '\0')
- {
- p = XNEWVEC (char, strlen (argv[i + 1]) + 2);
- p[0] = '-';
- p[1] = 'J';
- strcpy (&p[2], argv[i + 1]);
- i++;
- }
- else
- {
- p = XNEWVEC (char, strlen (argv[i]) + 1);
- strcpy (p, argv[i]);
- }
- append_arg (p);
- continue;
- }
+ {
+ char *p;
+
+ if (argv[i][2] == '\0')
+ {
+ p = XNEWVEC (char, strlen (argv[i + 1]) + 2);
+ p[0] = '-';
+ p[1] = 'J';
+ strcpy (&p[2], argv[i + 1]);
+ i++;
+ }
+ else
+ {
+ p = XNEWVEC (char, strlen (argv[i]) + 1);
+ strcpy (p, argv[i]);
+ }
+ append_arg (p);
+ continue;
+ }
if ((argv[i][0] == '-') && (argv[i][1] != 'l'))
{
*in_argv = g77_newargv;
}
+
/* Called before linking. Returns 0 on success and -1 on failure. */
int
lang_specific_pre_link (void) /* Not used for F77. */
/* Deal with interfaces.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "gfortran.h"
#include "match.h"
-
/* The current_interface structure holds information about the
interface currently being parsed. This structure is saved and
restored during recursive interfaces. */
/* Free a singly linked list of gfc_interface structures. */
void
-gfc_free_interface (gfc_interface * intr)
+gfc_free_interface (gfc_interface *intr)
{
gfc_interface *next;
static gfc_intrinsic_op
fold_unary (gfc_intrinsic_op operator)
{
-
switch (operator)
{
case INTRINSIC_UPLUS:
This subroutine doesn't return MATCH_NO. */
match
-gfc_match_generic_spec (interface_type * type,
+gfc_match_generic_spec (interface_type *type,
char *name,
gfc_intrinsic_op *operator)
{
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
return MATCH_ERROR;
-
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
- || (type != INTERFACE_NAMELESS
- && m != MATCH_YES))
+ || (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
- gfc_error
- ("Syntax error: Trailing garbage in INTERFACE statement at %C");
+ gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
+ "at %C");
return MATCH_ERROR;
}
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
- || (type != INTERFACE_NAMELESS
- && m != MATCH_YES))
+ || (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
- gfc_error
- ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
+ gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
+ "statement at %C");
return MATCH_ERROR;
}
case INTERFACE_USER_OP:
/* Comparing the symbol node names is OK because only use-associated
- symbols can be renamed. */
+ symbols can be renamed. */
if (type != current_interface.type
|| strcmp (current_interface.uop->name, name) != 0)
{
recursing through gfc_compare_types for the components. */
int
-gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
+gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
{
gfc_component *dt1, *dt2;
true names and module names are the same and the module name is
nonnull, then they are equal. */
if (strcmp (derived1->name, derived2->name) == 0
- && derived1 != NULL && derived2 != NULL
- && derived1->module != NULL && derived2->module != NULL
- && strcmp (derived1->module, derived2->module) == 0)
+ && derived1 != NULL && derived2 != NULL
+ && derived1->module != NULL && derived2->module != NULL
+ && strcmp (derived1->module, derived2->module) == 0)
return 1;
/* Compare type via the rules of the standard. Both types must have
return 0;
if (derived1->component_access == ACCESS_PRIVATE
- || derived2->component_access == ACCESS_PRIVATE)
+ || derived2->component_access == ACCESS_PRIVATE)
return 0;
if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
return 1;
}
+
/* Compare two typespecs, recursively if necessary. */
int
-gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
-
if (ts1->type != ts2->type)
return 0;
if (ts1->type != BT_DERIVED)
zero otherwise. */
static int
-compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
+compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
{
int r1, r2;
procedures. Returns nonzero if the same, zero if different. */
static int
-compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
+compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? 1 : 0;
if not found. */
static gfc_symbol *
-find_keyword_arg (const char *name, gfc_formal_arglist * f)
+find_keyword_arg (const char *name, gfc_formal_arglist *f)
{
-
for (; f; f = f->next)
if (strcmp (f->sym->name, name) == 0)
return f->sym;
interfaces for that operator are legal. */
static void
-check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
+check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
{
gfc_formal_arglist *formal;
sym_intent i1, i2;
{
if (!sym->attr.subroutine)
{
- gfc_error
- ("Assignment operator interface at %L must be a SUBROUTINE",
- &intr->where);
+ gfc_error ("Assignment operator interface at %L must be "
+ "a SUBROUTINE", &intr->where);
return;
}
if (args != 2)
{
- gfc_error
- ("Assignment operator interface at %L must have two arguments",
- &intr->where);
+ gfc_error ("Assignment operator interface at %L must have "
+ "two arguments", &intr->where);
return;
}
if (sym->formal->sym->ts.type != BT_DERIVED
- && sym->formal->next->sym->ts.type != BT_DERIVED
- && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
- || (gfc_numeric_ts (&sym->formal->sym->ts)
- && gfc_numeric_ts (&sym->formal->next->sym->ts))))
+ && sym->formal->next->sym->ts.type != BT_DERIVED
+ && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
+ || (gfc_numeric_ts (&sym->formal->sym->ts)
+ && gfc_numeric_ts (&sym->formal->next->sym->ts))))
{
- gfc_error
- ("Assignment operator interface at %L must not redefine "
- "an INTRINSIC type assignment", &intr->where);
+ gfc_error ("Assignment operator interface at %L must not redefine "
+ "an INTRINSIC type assignment", &intr->where);
return;
}
}
case INTRINSIC_PLUS: /* Numeric unary or binary */
case INTRINSIC_MINUS:
if ((args == 1)
- && (t1 == BT_INTEGER
- || t1 == BT_REAL
- || t1 == BT_COMPLEX))
+ && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX))
goto bad_repl;
if ((args == 2)
14.1.2.3. */
static int
-count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
+count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
int rc, ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
ac1++;
/* Count the number of arguments in f2 with that type, including
- those that are optional. */
+ those that are optional. */
ac2 = 0;
for (f = f2; f; f = f->next)
which is what happens here. */
static int
-operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
+operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
for (;;)
{
INTERFACE FOO
SUBROUTINE F1(A, B)
- INTEGER :: A ; REAL :: B
+ INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F2(B, A)
- INTEGER :: A ; REAL :: B
+ INTEGER :: A ; REAL :: B
END SUBROUTINE F1
END INTERFACE FOO
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
static int
-generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
+generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
-
gfc_formal_arglist *f2_save, *g;
gfc_symbol *sym;
goto next;
/* Now search for a disambiguating keyword argument starting at
- the current non-match. */
+ the current non-match. */
for (g = f1; g; g = g->next)
{
if (g->sym->attr.optional)
would be ambiguous between the two interfaces, zero otherwise. */
static int
-compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
+compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
{
gfc_formal_arglist *f1, *f2;
subroutines. Returns nonzero if something goes wrong. */
static int
-check_interface0 (gfc_interface * p, const char *interface_name)
+check_interface0 (gfc_interface *p, const char *interface_name)
{
gfc_interface *psave, *q, *qlast;
{
qlast = q;
q = q->next;
-
}
else
{
here. */
static int
-check_interface1 (gfc_interface * p, gfc_interface * q0,
+check_interface1 (gfc_interface *p, gfc_interface *q0,
int generic_flag, const char *interface_name,
bool referenced)
{
- gfc_interface * q;
+ gfc_interface *q;
for (; p; p = p->next)
for (q = q0; q; q = q->next)
{
after all of the symbols are actually loaded. */
static void
-check_sym_interfaces (gfc_symbol * sym)
+check_sym_interfaces (gfc_symbol *sym)
{
char interface_name[100];
bool k;
for (p = sym->generic; p; p = p->next)
{
- if (!p->sym->attr.use_assoc
- && p->sym->attr.mod_proc
- && p->sym->attr.if_source != IFSRC_DECL)
+ if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
+ && p->sym->attr.if_source != IFSRC_DECL)
{
gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
"from a module", p->sym->name, &p->where);
this is incorrect since host associated symbols, from any
source, cannot be ambiguous with local symbols. */
k = sym->attr.referenced || !sym->attr.use_assoc;
- if (check_interface1 (sym->generic, sym->generic, 1,
- interface_name, k))
+ if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
sym->attr.ambiguous_interfaces = 1;
}
}
static void
-check_uop_interfaces (gfc_user_op * uop)
+check_uop_interfaces (gfc_user_op *uop)
{
char interface_name[100];
gfc_user_op *uop2;
that most symbols will not have generic or operator interfaces. */
void
-gfc_check_interfaces (gfc_namespace * ns)
+gfc_check_interfaces (gfc_namespace *ns)
{
gfc_namespace *old_ns, *ns2;
char interface_name[100];
static int
-symbol_rank (gfc_symbol * sym)
+symbol_rank (gfc_symbol *sym)
{
-
return (sym->as == NULL) ? 0 : sym->as->rank;
}
allocatable. Returns nonzero if compatible, zero if not compatible. */
static int
-compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
+compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
pointer. Returns nonzero if compatible, zero if not compatible. */
static int
-compare_pointer (gfc_symbol * formal, gfc_expr * actual)
+compare_pointer (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
compatible, zero if not compatible. */
static int
-compare_parameter (gfc_symbol * formal, gfc_expr * actual,
+compare_parameter (gfc_symbol *formal, gfc_expr *actual,
int ranks_must_agree, int is_elemental)
{
gfc_ref *ref;
return 0;
if (formal->attr.if_source == IFSRC_UNKNOWN
- || actual->symtree->n.sym->attr.external)
+ || actual->symtree->n.sym->attr.external)
return 1; /* Assume match */
return compare_interfaces (formal, actual->symtree->n.sym, 0);
compatible, zero if not compatible. */
static int
-compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
+compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
{
if (actual->expr_type != EXPR_VARIABLE)
return 1;
code. */
static int
-compare_actual_formal (gfc_actual_arglist ** ap,
- gfc_formal_arglist * formal,
- int ranks_must_agree, int is_elemental, locus * where)
+compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+ int ranks_must_agree, int is_elemental, locus *where)
{
gfc_actual_arglist **new, *a, *actual, temp;
gfc_formal_arglist *f;
if (f == NULL)
{
if (where)
- gfc_error
- ("Keyword argument '%s' at %L is not in the procedure",
- a->name, &a->expr->where);
+ gfc_error ("Keyword argument '%s' at %L is not in "
+ "the procedure", a->name, &a->expr->where);
return 0;
}
if (new[i] != NULL)
{
if (where)
- gfc_error
- ("Keyword argument '%s' at %L is already associated "
- "with another actual argument", a->name, &a->expr->where);
+ gfc_error ("Keyword argument '%s' at %L is already associated "
+ "with another actual argument", a->name,
+ &a->expr->where);
return 0;
}
}
if (f == NULL)
{
if (where)
- gfc_error
- ("More actual than formal arguments in procedure call at %L",
- where);
+ gfc_error ("More actual than formal arguments in procedure "
+ "call at %L", where);
return 0;
}
if (f->sym == NULL)
{
if (where)
- gfc_error
- ("Missing alternate return spec in subroutine call at %L",
- where);
+ gfc_error ("Missing alternate return spec in subroutine call "
+ "at %L", where);
return 0;
}
if (a->expr == NULL)
{
if (where)
- gfc_error
- ("Unexpected alternate return spec in subroutine call at %L",
- where);
+ gfc_error ("Unexpected alternate return spec in subroutine "
+ "call at %L", where);
return 0;
}
- rank_check = where != NULL
- && !is_elemental
- && f->sym->as
- && (f->sym->as->type == AS_ASSUMED_SHAPE
- || f->sym->as->type == AS_DEFERRED);
+ rank_check = where != NULL && !is_elemental && f->sym->as
+ && (f->sym->as->type == AS_ASSUMED_SHAPE
+ || f->sym->as->type == AS_DEFERRED);
- if (!compare_parameter
- (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
+ if (!compare_parameter (f->sym, a->expr,
+ ranks_must_agree || rank_check, is_elemental))
{
if (where)
gfc_error ("Type/rank mismatch in argument '%s' at %L",
return 0;
}
- if (f->sym->attr.flavor == FL_PROCEDURE
- && f->sym->attr.pure
- && a->expr->ts.type == BT_PROCEDURE
- && !a->expr->symtree->n.sym->attr.pure)
+ if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
+ && a->expr->ts.type == BT_PROCEDURE
+ && !a->expr->symtree->n.sym->attr.pure)
{
if (where)
gfc_error ("Expected a PURE procedure for argument '%s' at %L",
return 0;
}
- if (f->sym->as
- && f->sym->as->type == AS_ASSUMED_SHAPE
+ if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym->as
&& a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
/* Check intent = OUT/INOUT for definable actual argument. */
if (a->expr->expr_type != EXPR_VARIABLE
- && (f->sym->attr.intent == INTENT_OUT
- || f->sym->attr.intent == INTENT_INOUT))
+ && (f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT))
{
if (where)
gfc_error ("Actual argument at %L must be definable to "
"match dummy INTENT = OUT/INOUT", &a->expr->where);
- return 0;
- }
+ return 0;
+ }
if (!compare_parameter_protected(f->sym, a->expr))
{
"PROTECTED attribute and dummy argument '%s' is "
"INTENT = OUT/INOUT",
&a->expr->where,f->sym->name);
- return 0;
+ return 0;
}
match:
if (f->sym == NULL)
{
if (where)
- gfc_error ("Missing alternate return spec in subroutine call at %L",
- where);
+ gfc_error ("Missing alternate return spec in subroutine call "
+ "at %L", where);
return 0;
}
if (!f->sym->attr.optional)
Returning FAILURE will produce no warning. */
static try
-compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
+compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
return FAILURE;
}
+
/* Given formal and actual argument lists that correspond to one
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
static try
-check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
+check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
gfc_formal_arglist *f1;
return non-zero if their intents are compatible, zero otherwise. */
static int
-compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
{
- if (actual->symtree->n.sym->attr.pointer
- && !formal->attr.pointer)
+ if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
return 1;
if (actual->symtree->n.sym->attr.intent != INTENT_IN)
return 1;
- if (formal->attr.intent == INTENT_INOUT
- || formal->attr.intent == INTENT_OUT)
+ if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
return 0;
return 1;
are not mismatched. */
static try
-check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
+check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f_intent;
if (!compare_parameter_intent(f->sym, a->expr))
{
-
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
"specifies INTENT(%s)", &a->expr->where,
gfc_intent_string (f_intent));
{
if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
{
- gfc_error
- ("Procedure argument at %L is local to a PURE procedure and "
- "is passed to an INTENT(%s) argument", &a->expr->where,
- gfc_intent_string (f_intent));
+ gfc_error ("Procedure argument at %L is local to a PURE "
+ "procedure and is passed to an INTENT(%s) argument",
+ &a->expr->where, gfc_intent_string (f_intent));
return FAILURE;
}
if (a->expr->symtree->n.sym->attr.pointer)
{
- gfc_error
- ("Procedure argument at %L is local to a PURE procedure and "
- "has the POINTER attribute", &a->expr->where);
+ gfc_error ("Procedure argument at %L is local to a PURE "
+ "procedure and has the POINTER attribute",
+ &a->expr->where);
return FAILURE;
}
}
sorted. */
void
-gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
+gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
/* Warn about calls with an implicit interface. */
if (gfc_option.warn_implicit_interface
&& sym->attr.if_source == IFSRC_UNKNOWN)
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
- sym->name, where);
+ sym->name, where);
if (sym->attr.if_source == IFSRC_UNKNOWN
|| !compare_actual_formal (ap, sym->formal, 0,
not found. */
gfc_symbol *
-gfc_search_interface (gfc_interface * intr, int sub_flag,
- gfc_actual_arglist ** ap)
+gfc_search_interface (gfc_interface *intr, int sub_flag,
+ gfc_actual_arglist **ap)
{
int r;
/* Do a brute force recursive search for a symbol. */
static gfc_symtree *
-find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
+find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
{
gfc_symtree * st;
/* Find a symtree for a symbol. */
static gfc_symtree *
-find_sym_in_symtree (gfc_symbol * sym)
+find_sym_in_symtree (gfc_symbol *sym)
{
gfc_symtree *st;
gfc_namespace *ns;
{
st = find_symtree0 (ns->sym_root, sym);
if (st)
- return st;
+ return st;
}
gfc_internal_error ("Unable to find symbol %s", sym->name);
/* Not reached */
the appropriate function call. */
try
-gfc_extend_expr (gfc_expr * e)
+gfc_extend_expr (gfc_expr *e)
{
gfc_actual_arglist *actual;
gfc_symbol *sym;
if (gfc_pure (NULL) && !gfc_pure (sym))
{
- gfc_error
- ("Function '%s' called in lieu of an operator at %L must be PURE",
- sym->name, &e->where);
+ gfc_error ("Function '%s' called in lieu of an operator at %L must "
+ "be PURE", sym->name, &e->where);
return FAILURE;
}
generated. */
try
-gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
+gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
/* Don't allow an intrinsic assignment to be replaced. */
if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
&& (lhs->ts.type == rhs->ts.type
- || (gfc_numeric_ts (&lhs->ts)
- && gfc_numeric_ts (&rhs->ts))))
+ || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
actual = gfc_get_actual_arglist ();
/* Add a symbol to the current interface. */
try
-gfc_add_interface (gfc_symbol * new)
+gfc_add_interface (gfc_symbol *new)
{
gfc_interface **head, *intr;
gfc_namespace *ns;
break;
case INTERFACE_USER_OP:
- if (check_new_interface (current_interface.uop->operator, new) ==
- FAILURE)
+ if (check_new_interface (current_interface.uop->operator, new)
+ == FAILURE)
return FAILURE;
head = ¤t_interface.uop->operator;
Symbols are freed when a namespace is freed. */
void
-gfc_free_formal_arglist (gfc_formal_arglist * p)
+gfc_free_formal_arglist (gfc_formal_arglist *p)
{
gfc_formal_arglist *q;
/* Build up a list of intrinsic subroutines and functions for the
name-resolution stage.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
-
/* Namespace to hold the resolved symbols for intrinsic subroutines. */
static gfc_namespace *gfc_intrinsic_namespace;
#define REQUIRED 0
#define OPTIONAL 1
+
/* Return a letter based on the passed type. Used to construct the
name of a type-dependent subroutine. */
/* Get a symbol for a resolved name. */
gfc_symbol *
-gfc_get_intrinsic_sub_symbol (const char * name)
+gfc_get_intrinsic_sub_symbol (const char *name)
{
gfc_symbol *sym;
typespecs. */
static const char *
-conv_name (gfc_typespec * from, gfc_typespec * to)
+conv_name (gfc_typespec *from, gfc_typespec *to)
{
static char name[30];
isn't found. */
static gfc_intrinsic_sym *
-find_conv (gfc_typespec * from, gfc_typespec * to)
+find_conv (gfc_typespec *from, gfc_typespec *to)
{
gfc_intrinsic_sym *sym;
const char *target;
function to manipulate the argument list. */
static try
-do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
+do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
Argument list:
char * name of function
- int whether function is elemental
- int If the function can be used as an actual argument [1]
- bt return type of function
- int kind of return type of function
- int Fortran standard version
+ int whether function is elemental
+ int If the function can be used as an actual argument [1]
+ bt return type of function
+ int kind of return type of function
+ int Fortran standard version
check pointer to check function
simplify pointer to simplification function
resolve pointer to resolution function
Optional arguments come in multiples of four:
char * name of argument
- bt type of argument
+ bt type of argument
int kind of argument
int arg optional flag (1=optional, 0=required)
static void
add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
- int kind, int standard,
- try (*check)(void),
- gfc_expr *(*simplify)(void),
- void (*resolve)(gfc_expr *))
+ int kind, int standard,
+ try (*check) (void),
+ gfc_expr *(*simplify) (void),
+ void (*resolve) (gfc_expr *))
{
gfc_simplify_f sf;
gfc_check_f cf;
rf.f0 = resolve;
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
- (void*)0);
+ (void *) 0);
}
0 arguments. */
static void
-add_sym_0s (const char * name, int standard,
- void (*resolve)(gfc_code *))
+add_sym_0s (const char *name, int standard, void (*resolve) (gfc_code *))
{
gfc_check_f cf;
gfc_simplify_f sf;
rf.s1 = resolve;
add_sym (name, ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, rf,
- (void*)0);
+ (void *) 0);
}
static void
add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
int kind, int standard,
- try (*check)(gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1)
+ try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1)
{
gfc_check_f cf;
gfc_simplify_f sf;
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
- (void*)0);
+ (void *) 0);
}
1 arguments. */
static void
-add_sym_1s (const char *name, int elemental, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *),
- void (*resolve)(gfc_code *),
- const char* a1, bt type1, int kind1, int optional1)
+add_sym_1s (const char *name, int elemental, bt type, int kind, int standard,
+ try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1)
{
gfc_check_f cf;
gfc_simplify_f sf;
add_sym (name, elemental, ACTUAL_NO, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
- (void*)0);
+ (void *) 0);
}
static void
add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
- int kind, int standard,
- try (*check)(gfc_actual_arglist *),
- gfc_expr *(*simplify)(gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_actual_arglist *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2)
+ int kind, int standard,
+ try (*check) (gfc_actual_arglist *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_actual_arglist *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
- (void*)0);
+ (void *) 0);
}
static void
add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2)
+ int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
- (void*)0);
+ (void *) 0);
}
2 arguments. */
static void
-add_sym_2s (const char *name, int elemental, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_code *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2)
+add_sym_2s (const char *name, int elemental, bt type, int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2)
{
gfc_check_f cf;
gfc_simplify_f sf;
add_sym (name, elemental, ACTUAL_NO, type, kind, standard, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
- (void*)0);
+ (void *) 0);
}
static void
add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3)
+ int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3)
{
gfc_check_f cf;
gfc_simplify_f sf;
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
- (void*)0);
+ (void *) 0);
}
might have to be reordered. */
static void
-add_sym_3ml (const char *name, int elemental,
- int actual_ok, bt type, int kind, int standard,
- try (*check)(gfc_actual_arglist *),
- gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3)
+add_sym_3ml (const char *name, int elemental, int actual_ok, bt type,
+ int kind, int standard,
+ try (*check) (gfc_actual_arglist *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3)
{
gfc_check_f cf;
gfc_simplify_f sf;
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
- (void*)0);
+ (void *) 0);
}
their argument also might have to be reordered. */
static void
-add_sym_3red (const char *name, int elemental,
- int actual_ok, bt type, int kind, int standard,
- try (*check)(gfc_actual_arglist *),
- gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3)
+add_sym_3red (const char *name, int elemental, int actual_ok, bt type,
+ int kind, int standard,
+ try (*check) (gfc_actual_arglist *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3)
{
gfc_check_f cf;
gfc_simplify_f sf;
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
- (void*)0);
+ (void *) 0);
}
3 arguments. */
static void
-add_sym_3s (const char *name, int elemental, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_code *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3)
+add_sym_3s (const char *name, int elemental, bt type, int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3)
{
gfc_check_f cf;
gfc_simplify_f sf;
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
- (void*)0);
+ (void *) 0);
}
static void
add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
- int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3,
- const char* a4, bt type4, int kind4, int optional4 )
+ int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3,
+ const char *a4, bt type4, int kind4, int optional4 )
{
gfc_check_f cf;
gfc_simplify_f sf;
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
- (void*)0);
+ (void *) 0);
}
4 arguments. */
static void
-add_sym_4s (const char *name, int elemental,
- bt type, int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_code *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3,
- const char* a4, bt type4, int kind4, int optional4)
+add_sym_4s (const char *name, int elemental, bt type, int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3,
+ const char *a4, bt type4, int kind4, int optional4)
{
gfc_check_f cf;
gfc_simplify_f sf;
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
- (void*)0);
+ (void *) 0);
}
5 arguments. */
static void
-add_sym_5s (const char *name, int elemental,
- bt type, int kind, int standard,
- try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
- void (*resolve)(gfc_code *),
- const char* a1, bt type1, int kind1, int optional1,
- const char* a2, bt type2, int kind2, int optional2,
- const char* a3, bt type3, int kind3, int optional3,
- const char* a4, bt type4, int kind4, int optional4,
- const char* a5, bt type5, int kind5, int optional5)
+add_sym_5s (const char *name, int elemental, bt type, int kind, int standard,
+ try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1,
+ const char *a2, bt type2, int kind2, int optional2,
+ const char *a3, bt type3, int kind3, int optional3,
+ const char *a4, bt type4, int kind4, int optional4,
+ const char *a5, bt type5, int kind5, int optional5)
{
gfc_check_f cf;
gfc_simplify_f sf;
a3, type3, kind3, optional3,
a4, type4, kind4, optional4,
a5, type5, kind5, optional5,
- (void*)0);
+ (void *) 0);
}
a name is not found. */
static gfc_intrinsic_sym *
-find_sym (gfc_intrinsic_sym * start, int n, const char *name)
+find_sym (gfc_intrinsic_sym *start, int n, const char *name)
{
-
while (n > 0)
{
if (strcmp (name, start->name) == 0)
static gfc_intrinsic_sym *
find_subroutine (const char *name)
{
-
return find_sym (subroutines, nsub, name);
}
int
gfc_intrinsic_name (const char *name, int subroutine_flag)
{
-
- return subroutine_flag ?
- find_subroutine (name) != NULL : gfc_find_function (name) != NULL;
+ return subroutine_flag ? find_subroutine (name) != NULL
+ : gfc_find_function (name) != NULL;
}
static void
make_alias (const char *name, int standard)
{
-
/* First check that the intrinsic belongs to the selected standard.
If not, don't add it to the symbol list. */
if (!(gfc_option.allow_std & standard)
}
}
+
/* Make the current subroutine noreturn. */
static void
-make_noreturn(void)
+make_noreturn (void)
{
if (sizing == SZ_NOTHING)
- next_sym[-1].noreturn = 1;
+ next_sym[-1].noreturn = 1;
}
+
/* Add intrinsic functions. */
static void
add_functions (void)
{
-
/* Argument names as in the standard (to be used as argument keywords). */
const char
*a = "a", *f = "field", *pt = "pointer", *tg = "target",
GFC_STD_F2003, NULL, NULL, NULL);
make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
- GFC_STD_F2003);
+ GFC_STD_F2003);
add_sym_2 ("complex", ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
add_sym_1 ("ctime", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
- gfc_check_ctime, NULL, gfc_resolve_ctime,
+ gfc_check_ctime, NULL, gfc_resolve_ctime,
tm, BT_INTEGER, di, REQUIRED);
make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
/* The following function is for G77 compatibility. */
add_sym_1 ("irand", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU,
- gfc_check_irand, NULL, NULL,
+ gfc_check_irand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
add_sym_3red ("maxval", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
- gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
+ gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
add_sym_1m ("min", ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
- a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+ a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("min0", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
gfc_check_min_max_integer, gfc_simplify_min, NULL,
- a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+ a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
add_sym_1m ("amin0", ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_min_max_integer, gfc_simplify_min, NULL,
- a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
+ a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
add_sym_1m ("amin1", ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
gfc_check_min_max_real, gfc_simplify_min, NULL,
- a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+ a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("min1", ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
gfc_check_min_max_real, gfc_simplify_min, NULL,
- a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
+ a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
add_sym_1m ("dmin1", ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
gfc_check_min_max_double, gfc_simplify_min, NULL,
- a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
+ a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
add_sym_3red ("minval", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
- gfc_check_minval_maxval, NULL, gfc_resolve_minval,
+ gfc_check_minval_maxval, NULL, gfc_resolve_minval,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
add_sym_1 ("new_line", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc,
GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
- i, BT_CHARACTER, dc, REQUIRED);
+ i, BT_CHARACTER, dc, REQUIRED);
add_sym_2 ("nint", ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
add_sym_3red ("product", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
- gfc_check_product_sum, NULL, gfc_resolve_product,
+ gfc_check_product_sum, NULL, gfc_resolve_product,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
/* The following function is for G77 compatibility. */
add_sym_1 ("rand", NOT_ELEMENTAL, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
- gfc_check_rand, NULL, NULL,
- i, BT_INTEGER, 4, OPTIONAL);
+ gfc_check_rand, NULL, NULL,
+ i, BT_INTEGER, 4, OPTIONAL);
/* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
use slightly different shoddy multiplicative congruential PRNG. */
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
add_sym_3red ("sum", NOT_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_product_sum, NULL, gfc_resolve_sum,
+ gfc_check_product_sum, NULL, gfc_resolve_sum,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
add_sym_1 ("ttynam", NOT_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
- gfc_check_ttynam, NULL, gfc_resolve_ttynam,
- ut, BT_INTEGER, di, REQUIRED);
+ gfc_check_ttynam, NULL, gfc_resolve_ttynam,
+ ut, BT_INTEGER, di, REQUIRED);
make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
add_sym_1 ("loc", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
- gfc_check_loc, NULL, gfc_resolve_loc,
- ar, BT_UNKNOWN, 0, REQUIRED);
+ gfc_check_loc, NULL, gfc_resolve_loc,
+ ar, BT_UNKNOWN, 0, REQUIRED);
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
-
}
tm, BT_REAL, dr, REQUIRED);
add_sym_2s ("chdir", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
+ gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("chmod", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
+ gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
/* More G77 compatibility garbage. */
add_sym_2s ("etime", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
+ gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_2s ("dtime", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
+ gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_1s ("fdate", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
- dt, BT_CHARACTER, dc, REQUIRED);
+ gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
+ dt, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("gerror", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
+ gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
dc, REQUIRED);
add_sym_2s ("getcwd", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
+ gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("getenv", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, NULL,
- name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
+ name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
+ REQUIRED);
add_sym_2s ("getarg", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getarg,
c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("getlog", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
+ gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
dc, REQUIRED);
/* F2003 commandline routines. */
add_sym_3s ("get_command", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_command,
- com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
+ com, BT_CHARACTER, dc, OPTIONAL,
+ length, BT_INTEGER, di, OPTIONAL,
st, BT_INTEGER, di, OPTIONAL);
add_sym_4s ("get_command_argument", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
/* F2003 subroutine to get environment variables. */
add_sym_5s ("get_environment_variable", 0, BT_UNKNOWN, 0, GFC_STD_F2003,
- NULL, NULL, gfc_resolve_get_environment_variable,
- name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
+ NULL, NULL, gfc_resolve_get_environment_variable,
+ name, BT_CHARACTER, dc, REQUIRED,
+ val, BT_CHARACTER, dc, OPTIONAL,
length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
trim_name, BT_LOGICAL, dl, OPTIONAL);
h, BT_REAL, dr, REQUIRED);
add_sym_3s ("random_seed", 0, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_random_seed, NULL, NULL,
+ gfc_check_random_seed, NULL, NULL,
sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
gt, BT_INTEGER, di, OPTIONAL);
st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("srand", 0, BT_UNKNOWN, di, GFC_STD_GNU,
- gfc_check_srand, NULL, gfc_resolve_srand,
+ gfc_check_srand, NULL, gfc_resolve_srand,
c, BT_INTEGER, 4, REQUIRED);
add_sym_1s ("exit", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_exit, NULL, gfc_resolve_exit,
+ gfc_check_exit, NULL, gfc_resolve_exit,
c, BT_INTEGER, di, OPTIONAL);
if ((gfc_option.allow_std & GFC_STD_GNU) || gfc_option.flag_all_intrinsics)
ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
add_sym_2s ("hostnm", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
+ gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("kill", 0, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("link", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_link_sub, NULL, gfc_resolve_link_sub,
+ gfc_check_link_sub, NULL, gfc_resolve_link_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("perror", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_perror, NULL, gfc_resolve_perror,
+ gfc_check_perror, NULL, gfc_resolve_perror,
c, BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("rename", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
+ gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("sleep", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
+ gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
val, BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("fstat", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("symlnk", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
+ gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("system_clock", 0, BT_UNKNOWN, 0, GFC_STD_F95,
- gfc_check_system_clock, NULL, gfc_resolve_system_clock,
+ gfc_check_system_clock, NULL, gfc_resolve_system_clock,
c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
cm, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("ttynam", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
+ gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
add_sym_2s ("umask", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
+ gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("unlink", 0, BT_UNKNOWN, 0, GFC_STD_GNU,
- gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
+ gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
-
}
static void
add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
{
-
gfc_typespec from, to;
gfc_intrinsic_sym *sym;
have been left behind by a sort against some formal argument list. */
static void
-remove_nullargs (gfc_actual_arglist ** ap)
+remove_nullargs (gfc_actual_arglist **ap)
{
gfc_actual_arglist *head, *tail, *next;
return FAILURE. */
static try
-sort_actual (const char *name, gfc_actual_arglist ** ap,
- gfc_intrinsic_arg * formal, locus * where)
+sort_actual (const char *name, gfc_actual_arglist **ap,
+ gfc_intrinsic_arg *formal, locus *where)
{
-
gfc_actual_arglist *actual, *a;
gfc_intrinsic_arg *f;
return SUCCESS;
for (;;)
- { /* Put the nonkeyword arguments in a 1:1 correspondence */
+ { /* Put the nonkeyword arguments in a 1:1 correspondence */
if (f == NULL)
break;
if (a == NULL)
"context", where);
else
gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
- a->name, name, where);
+ a->name, name, where);
return FAILURE;
}
for arrayness here. */
static try
-check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
+check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
int error_flag)
{
gfc_actual_arglist *actual;
if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
{
if (error_flag)
- gfc_error
- ("Type of argument '%s' in call to '%s' at %L should be "
- "%s, not %s", gfc_current_intrinsic_arg[i],
- gfc_current_intrinsic, &actual->expr->where,
- gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
+ gfc_error ("Type of argument '%s' in call to '%s' at %L should "
+ "be %s, not %s", gfc_current_intrinsic_arg[i],
+ gfc_current_intrinsic, &actual->expr->where,
+ gfc_typename (&formal->ts),
+ gfc_typename (&actual->expr->ts));
return FAILURE;
}
}
of the result. This may involve calling a resolution subroutine. */
static void
-resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
+resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
gfc_actual_arglist *arg;
if nothing has changed in the expression itself. */
static try
-do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
+do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
{
gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
gfc_actual_arglist *arg;
list cannot match any intrinsic. */
static void
-init_arglist (gfc_intrinsic_sym * isym)
+init_arglist (gfc_intrinsic_sym *isym)
{
gfc_intrinsic_arg *formal;
int i;
and intrinsic match, FAILURE otherwise. */
static try
-check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
+check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
{
gfc_actual_arglist *arg, **ap;
int r;
return FAILURE;
if (specific->check.f3ml == gfc_check_minloc_maxloc)
- /* This is special because we might have to reorder the argument
- list. */
+ /* This is special because we might have to reorder the argument list. */
t = gfc_check_minloc_maxloc (*ap);
else if (specific->check.f3red == gfc_check_minval_maxval)
/* This is also special because we also might have to reorder the
if (arg->expr->rank != r)
{
- gfc_error
- ("Ranks of arguments to elemental intrinsic '%s' differ "
- "at %L", specific->name, &arg->expr->where);
+ gfc_error ("Ranks of arguments to elemental intrinsic '%s' "
+ "differ at %L", specific->name, &arg->expr->where);
return FAILURE;
}
}
has chosen. */
static void
-check_intrinsic_standard (const char *name, int standard, locus * where)
+check_intrinsic_standard (const char *name, int standard, locus *where)
{
if (!gfc_option.warn_nonstd_intrinsics)
return;
We return:
MATCH_YES if the call corresponds to an intrinsic, simplification
- is done if possible.
+ is done if possible.
MATCH_NO if the call does not correspond to an intrinsic
MATCH_ERROR if the call corresponds to an intrinsic but there was an
- error during the simplification process.
+ error during the simplification process.
The error_flag parameter enables an error reporting. */
match
-gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
+gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
{
gfc_intrinsic_sym *isym, *specific;
gfc_actual_arglist *actual;
if (expr->value.function.isym != NULL)
return (do_simplify (expr->value.function.isym, expr) == FAILURE)
- ? MATCH_ERROR : MATCH_YES;
+ ? MATCH_ERROR : MATCH_YES;
gfc_suppress_error = !error_flag;
flag = 0;
if (gfc_init_expr && flag && gfc_init_expr_extensions (specific))
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
- "nonstandard initialization expression at %L", &expr->where)
- == FAILURE)
+ "nonstandard initialization expression at %L",
+ &expr->where) == FAILURE)
{
return MATCH_ERROR;
}
correspond). */
match
-gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
+gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
{
gfc_intrinsic_sym *isym;
const char *name;
/* Call gfc_convert_type() with warning enabled. */
try
-gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
+gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
{
return gfc_convert_type_warn (expr, ts, eflag, 1);
}
'wflag' controls the warning related to conversion. */
try
-gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
- int wflag)
+gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
{
gfc_intrinsic_sym *sym;
gfc_typespec from_ts;
/* NULL and zero size arrays get their type here. */
if (expr->expr_type == EXPR_NULL
- || (expr->expr_type == EXPR_ARRAY
- && expr->value.constructor == NULL))
+ || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
{
/* Sometimes the RHS acquire the type. */
expr->ts = *ts;
if (expr->ts.type == BT_UNKNOWN)
goto bad;
- if (expr->ts.type == BT_DERIVED
- && ts->type == BT_DERIVED
+ if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
&& gfc_compare_types (&expr->ts, ts))
return SUCCESS;
/* Deal with I/O statements & related stuff.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "match.h"
#include "parse.h"
-gfc_st_label format_asterisk =
- {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
- 0, {NULL, NULL}};
+gfc_st_label
+format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
+ 0, {NULL, NULL}};
typedef struct
{
tag_unit = {"UNIT", " unit = %e", BT_INTEGER},
tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER},
tag_rec = {"REC", " rec = %e", BT_INTEGER},
- tag_spos = {"POSITION", " pos = %e", BT_INTEGER},
+ tag_spos = {"POSITION", " pos = %e", BT_INTEGER},
tag_format = {"FORMAT", NULL, BT_CHARACTER},
tag_iomsg = {"IOMSG", " iomsg = %e", BT_CHARACTER},
tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER},
static void
unget_char (void)
{
-
use_last_char = 1;
}
/* Eat up the spaces and return a character. */
static char
-next_char_not_space(void)
+next_char_not_space (void)
{
char c;
do
do
{
c = next_char_not_space ();
- if(ISDIGIT (c))
- value = 10 * value + c - '0';
+ if (ISDIGIT (c))
+ value = 10 * value + c - '0';
}
while (ISDIGIT (c));
unget_char ();
if (negative_flag)
- value = -value;
+ value = -value;
token = FMT_SIGNED_INT;
break;
c = next_char_not_space ();
if (c != '0')
zflag = 0;
- if (ISDIGIT (c))
- value = 10 * value + c - '0';
+ if (ISDIGIT (c))
+ value = 10 * value + c - '0';
}
while (ISDIGIT (c));
break;
}
}
- value++;
+ value++;
}
break;
t = format_lex ();
if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
- == FAILURE)
- return FAILURE;
+ == FAILURE)
+ return FAILURE;
if (t != FMT_RPAREN || level > 0)
{
gfc_warning ("$ should be the last specifier in format at %C");
switch (gfc_notification_std (GFC_STD_GNU))
{
case WARNING:
- gfc_warning
- ("Extension: Missing positive width after L descriptor at %C");
+ gfc_warning ("Extension: Missing positive width after L "
+ "descriptor at %C");
saved_token = t;
break;
if (t != FMT_PERIOD)
{
/* Warn if -std=legacy, otherwise error. */
- if (gfc_option.warn_std != 0)
+ if (gfc_option.warn_std != 0)
gfc_error_now ("Period required in format specifier at %C");
else
gfc_warning ("Period required in format specifier at %C");
case FMT_H:
if(mode == MODE_STRING)
{
- format_string += value;
- format_length -= value;
+ format_string += value;
+ format_length -= value;
}
else
{
- while(repeat >0)
- {
- next_char(1);
- repeat -- ;
- }
+ while (repeat >0)
+ {
+ next_char (1);
+ repeat -- ;
+ }
}
break;
gfc_warning ("%s in format string at %C", error);
/* TODO: More elaborate measures are needed to show where a problem
- is within a format string that has been calculated. */
+ is within a format string that has been calculated. */
}
rv = FAILURE;
like a format string. */
static void
-check_format_string (gfc_expr * e)
+check_format_string (gfc_expr *e)
{
-
mode = MODE_STRING;
format_string = e->value.character.string;
check_format ();
locus start;
if (gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
{
gfc_error ("Format statement in module main block at %C");
return MATCH_ERROR;
e->ts.type = BT_CHARACTER;
e->ts.kind = gfc_default_character_kind;
e->where = start;
- e->value.character.string = format_string = gfc_getmem(format_length+1);
+ e->value.character.string = format_string = gfc_getmem (format_length + 1);
e->value.character.length = format_length;
gfc_statement_label->format = e;
/* Match an expression I/O tag of some sort. */
static match
-match_etag (const io_tag * tag, gfc_expr ** v)
+match_etag (const io_tag *tag, gfc_expr **v)
{
gfc_expr *result;
match m;
/* Match a variable I/O tag of some sort. */
static match
-match_vtag (const io_tag * tag, gfc_expr ** v)
+match_vtag (const io_tag *tag, gfc_expr **v)
{
gfc_expr *result;
match m;
/* Match a label I/O tag. */
static match
-match_ltag (const io_tag * tag, gfc_st_label ** label)
+match_ltag (const io_tag *tag, gfc_st_label ** label)
{
match m;
gfc_st_label *old;
/* Do expression resolution and type-checking on an expression tag. */
static try
-resolve_tag (const io_tag * tag, gfc_expr * e)
+resolve_tag (const io_tag *tag, gfc_expr *e)
{
-
if (e == NULL)
return SUCCESS;
if (e->ts.type != tag->type && tag != &tag_format)
{
gfc_error ("%s tag at %L must be of type %s", tag->name,
- &e->where, gfc_basic_typename (tag->type));
+ &e->where, gfc_basic_typename (tag->type));
return FAILURE;
}
of integer or character type. The integer variable should be
ASSIGNED. */
if (e->symtree == NULL || e->symtree->n.sym->as == NULL
- || e->symtree->n.sym->as->rank == 0)
+ || e->symtree->n.sym->as->rank == 0)
{
if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
{
gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
- &e->where, gfc_basic_typename (BT_CHARACTER),
- gfc_basic_typename (BT_INTEGER));
+ &e->where, gfc_basic_typename (BT_CHARACTER),
+ gfc_basic_typename (BT_INTEGER));
return FAILURE;
}
else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: ASSIGNED variable in FORMAT tag at %L",
- &e->where) == FAILURE)
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGNED "
+ "variable in FORMAT tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
if (e->symtree->n.sym->attr.assign != 1)
{
gfc_error ("Variable '%s' at %L has not been assigned a "
- "format label", e->symtree->n.sym->name, &e->where);
+ "format label", e->symtree->n.sym->name,
+ &e->where);
return FAILURE;
}
}
else if (e->ts.type == BT_INTEGER)
{
gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED "
- "variable", gfc_basic_typename (e->ts.type), &e->where);
+ "variable", gfc_basic_typename (e->ts.type),
+ &e->where);
return FAILURE;
}
assigned an Hollerith constant. */
if (e->ts.type == BT_CHARACTER)
{
- if (gfc_notify_std (GFC_STD_GNU,
- "Extension: Character array in FORMAT tag at %L",
- &e->where) == FAILURE)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
+ "in FORMAT tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
}
else
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Extension: Non-character in FORMAT tag at %L",
- &e->where) == FAILURE)
+ if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
+ "in FORMAT tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
}
return SUCCESS;
if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
- "INTEGER in IOSTAT tag at %L",
- &e->where) == FAILURE)
+ "INTEGER in IOSTAT tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
}
if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
- "INTEGER in SIZE tag at %L",
- &e->where) == FAILURE)
+ "INTEGER in SIZE tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
}
if (tag == &tag_iolength && e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
- "INTEGER in IOLENGTH tag at %L",
- &e->where) == FAILURE)
+ "INTEGER in IOLENGTH tag at %L", &e->where)
+ == FAILURE)
return FAILURE;
}
}
/* Match a single tag of an OPEN statement. */
static match
-match_open_element (gfc_open * open)
+match_open_element (gfc_open *open)
{
match m;
/* Free the gfc_open structure and all the expressions it contains. */
void
-gfc_free_open (gfc_open * open)
+gfc_free_open (gfc_open *open)
{
-
if (open == NULL)
return;
gfc_free_expr (open->delim);
gfc_free_expr (open->pad);
gfc_free_expr (open->convert);
-
gfc_free (open);
}
/* Resolve everything in a gfc_open structure. */
try
-gfc_resolve_open (gfc_open * open)
+gfc_resolve_open (gfc_open *open)
{
RESOLVE_TAG (&tag_unit, open->unit);
RESOLVE_TAG (&tag_e_access, open->access);
RESOLVE_TAG (&tag_e_form, open->form);
RESOLVE_TAG (&tag_e_recl, open->recl);
-
RESOLVE_TAG (&tag_e_blank, open->blank);
RESOLVE_TAG (&tag_e_position, open->position);
RESOLVE_TAG (&tag_e_action, open->action);
}
-
/* Check if a given value for a SPECIFIER is either in the list of values
allowed in F95 or F2003, issuing an error message and returning a zero
value if it is not allowed. */
+
static int
-compare_to_allowed_values (const char * specifier, const char * allowed[],
- const char * allowed_f2003[],
- const char * allowed_gnu[], char * value,
- const char * statement, bool warn)
+compare_to_allowed_values (const char *specifier, const char *allowed[],
+ const char *allowed_f2003[],
+ const char *allowed_gnu[], char *value,
+ const char *statement, bool warn)
{
int i;
unsigned int len;
- len = strlen(value);
+ len = strlen (value);
if (len > 0)
{
for (len--; len > 0; len--)
}
for (i = 0; allowed[i]; i++)
- if (len == strlen(allowed[i])
- && strncasecmp (value, allowed[i], strlen(allowed[i])) == 0)
+ if (len == strlen (allowed[i])
+ && strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
return 1;
for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
- if (len == strlen(allowed_f2003[i])
- && strncasecmp (value, allowed_f2003[i], strlen(allowed_f2003[i])) == 0)
+ if (len == strlen (allowed_f2003[i])
+ && strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i]))
+ == 0)
{
notification n = gfc_notification_std (GFC_STD_F2003);
}
for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
- if (len == strlen(allowed_gnu[i])
- && strncasecmp (value, allowed_gnu[i], strlen(allowed_gnu[i])) == 0)
+ if (len == strlen (allowed_gnu[i])
+ && strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0)
{
notification n = gfc_notification_std (GFC_STD_GNU);
}
}
+
/* Match an OPEN statement. */
match
/* Checks on the ACCESS specifier. */
if (open->access && open->access->expr_type == EXPR_CONSTANT)
{
- static const char * access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
- static const char * access_f2003[] = { "STREAM", NULL };
- static const char * access_gnu[] = { "APPEND", NULL };
+ static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
+ static const char *access_f2003[] = { "STREAM", NULL };
+ static const char *access_gnu[] = { "APPEND", NULL };
if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
access_gnu,
/* Checks on the ACTION specifier. */
if (open->action && open->action->expr_type == EXPR_CONSTANT)
{
- static const char * action[] = { "READ", "WRITE", "READWRITE", NULL };
+ static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
open->action->value.character.string,
/* Checks on the BLANK specifier. */
if (open->blank && open->blank->expr_type == EXPR_CONSTANT)
{
- static const char * blank[] = { "ZERO", "NULL", NULL };
+ static const char *blank[] = { "ZERO", "NULL", NULL };
if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
open->blank->value.character.string,
/* Checks on the DELIM specifier. */
if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
{
- static const char * delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+ static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
open->delim->value.character.string,
/* Checks on the FORM specifier. */
if (open->form && open->form->expr_type == EXPR_CONSTANT)
{
- static const char * form[] = { "FORMATTED", "UNFORMATTED", NULL };
+ static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
open->form->value.character.string,
/* Checks on the PAD specifier. */
if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
{
- static const char * pad[] = { "YES", "NO", NULL };
+ static const char *pad[] = { "YES", "NO", NULL };
if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
open->pad->value.character.string,
/* Checks on the POSITION specifier. */
if (open->position && open->position->expr_type == EXPR_CONSTANT)
{
- static const char * position[] = { "ASIS", "REWIND", "APPEND", NULL };
+ static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
open->position->value.character.string,
/* Checks on the STATUS specifier. */
if (open->status && open->status->expr_type == EXPR_CONSTANT)
{
- static const char * status[] = { "OLD", "NEW", "SCRATCH",
+ static const char *status[] = { "OLD", "NEW", "SCRATCH",
"REPLACE", "UNKNOWN", NULL };
if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
goto cleanup;
/* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
- the FILE= specifier shall appear. */
- if (open->file == NULL &&
- (strncasecmp (open->status->value.character.string, "replace", 7) == 0
- || strncasecmp (open->status->value.character.string, "new", 3) == 0))
+ the FILE= specifier shall appear. */
+ if (open->file == NULL
+ && (strncasecmp (open->status->value.character.string, "replace", 7)
+ == 0
+ || strncasecmp (open->status->value.character.string, "new", 3)
+ == 0))
{
- warn_or_error ("The STATUS specified in OPEN statement at %C is '%s' "
- "and no FILE specifier is present",
+ warn_or_error ("The STATUS specified in OPEN statement at %C is "
+ "'%s' and no FILE specifier is present",
open->status->value.character.string);
}
/* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
the FILE= specifier shall not appear. */
- if (strncasecmp (open->status->value.character.string, "scratch", 7) == 0
- && open->file)
+ if (strncasecmp (open->status->value.character.string, "scratch", 7)
+ == 0 && open->file)
{
- warn_or_error ("The STATUS specified in OPEN statement at %C cannot "
- "have the value SCRATCH if a FILE specifier "
+ warn_or_error ("The STATUS specified in OPEN statement at %C "
+ "cannot have the value SCRATCH if a FILE specifier "
"is present");
}
}
&& strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0)
{
- const char * spec = (open->delim ? "DELIM " : (open->pad ? "PAD " :
- open->blank ? "BLANK " : ""));
+ const char *spec = (open->delim ? "DELIM "
+ : (open->pad ? "PAD " : open->blank
+ ? "BLANK " : ""));
- warn_or_error ("%sspecifier at %C not allowed in OPEN statement for "
+ warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
"unformatted I/O", spec);
}
"stream I/O");
}
- if (open->position && open->access && open->access->expr_type == EXPR_CONSTANT
+ if (open->position
+ && open->access && open->access->expr_type == EXPR_CONSTANT
&& !(strncasecmp (open->access->value.character.string,
"sequential", 10) == 0
|| strncasecmp (open->access->value.character.string,
/* Free a gfc_close structure an all its expressions. */
void
-gfc_free_close (gfc_close * close)
+gfc_free_close (gfc_close *close)
{
-
if (close == NULL)
return;
gfc_free_expr (close->iomsg);
gfc_free_expr (close->iostat);
gfc_free_expr (close->status);
-
gfc_free (close);
}
/* Match elements of a CLOSE statement. */
static match
-match_close_element (gfc_close * close)
+match_close_element (gfc_close *close)
{
match m;
/* Checks on the STATUS specifier. */
if (close->status && close->status->expr_type == EXPR_CONSTANT)
{
- static const char * status[] = { "KEEP", "DELETE", NULL };
+ static const char *status[] = { "KEEP", "DELETE", NULL };
if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
close->status->value.character.string,
/* Resolve everything in a gfc_close structure. */
try
-gfc_resolve_close (gfc_close * close)
+gfc_resolve_close (gfc_close *close)
{
-
RESOLVE_TAG (&tag_unit, close->unit);
RESOLVE_TAG (&tag_iomsg, close->iomsg);
RESOLVE_TAG (&tag_iostat, close->iostat);
/* Free a gfc_filepos structure. */
void
-gfc_free_filepos (gfc_filepos * fp)
+gfc_free_filepos (gfc_filepos *fp)
{
-
gfc_free_expr (fp->unit);
gfc_free_expr (fp->iomsg);
gfc_free_expr (fp->iostat);
/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */
static match
-match_file_element (gfc_filepos * fp)
+match_file_element (gfc_filepos *fp)
{
match m;
try
-gfc_resolve_filepos (gfc_filepos * fp)
+gfc_resolve_filepos (gfc_filepos *fp)
{
-
RESOLVE_TAG (&tag_unit, fp->unit);
RESOLVE_TAG (&tag_iostat, fp->iostat);
RESOLVE_TAG (&tag_iomsg, fp->iomsg);
match
gfc_match_endfile (void)
{
-
return match_filepos (ST_END_FILE, EXEC_ENDFILE);
}
match
gfc_match_backspace (void)
{
-
return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
}
match
gfc_match_rewind (void)
{
-
return match_filepos (ST_REWIND, EXEC_REWIND);
}
match
gfc_match_flush (void)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
+ == FAILURE)
return MATCH_ERROR;
return match_filepos (ST_FLUSH, EXEC_FLUSH);
/* Match a unit specification for a data transfer statement. */
static match
-match_dt_unit (io_kind k, gfc_dt * dt)
+match_dt_unit (io_kind k, gfc_dt *dt)
{
gfc_expr *e;
/* Match a format specification. */
static match
-match_dt_format (gfc_dt * dt)
+match_dt_format (gfc_dt *dt)
{
locus where;
gfc_expr *e;
nonzero if we find such a variable. */
static int
-check_namelist (gfc_symbol * sym)
+check_namelist (gfc_symbol *sym)
{
gfc_namelist *p;
/* Match a single data transfer element. */
static match
-match_dt_element (io_kind k, gfc_dt * dt)
+match_dt_element (io_kind k, gfc_dt *dt)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
{
if (k == M_WRITE)
{
- gfc_error ("END tag at %C not allowed in output statement");
- return MATCH_ERROR;
+ gfc_error ("END tag at %C not allowed in output statement");
+ return MATCH_ERROR;
}
dt->end_where = gfc_current_locus;
}
/* Free a data transfer structure and everything below it. */
void
-gfc_free_dt (gfc_dt * dt)
+gfc_free_dt (gfc_dt *dt)
{
-
if (dt == NULL)
return;
gfc_free_expr (dt->iomsg);
gfc_free_expr (dt->iostat);
gfc_free_expr (dt->size);
-
gfc_free (dt);
}
/* Resolve everything in a gfc_dt structure. */
try
-gfc_resolve_dt (gfc_dt * dt)
+gfc_resolve_dt (gfc_dt *dt)
{
gfc_expr *e;
e = dt->io_unit;
if (gfc_resolve_expr (e) == SUCCESS
&& (e->ts.type != BT_INTEGER
- && (e->ts.type != BT_CHARACTER
- || e->expr_type != EXPR_VARIABLE)))
+ && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
{
- gfc_error
- ("UNIT specification at %L must be an INTEGER expression or a "
- "CHARACTER variable", &e->where);
+ gfc_error ("UNIT specification at %L must be an INTEGER expression "
+ "or a CHARACTER variable", &e->where);
return FAILURE;
}
{
if (gfc_has_vector_index (e))
{
- gfc_error ("Internal unit with vector subscript at %L",
- &e->where);
+ gfc_error ("Internal unit with vector subscript at %L", &e->where);
return FAILURE;
}
}
&& dt->format_label->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
- &dt->format_label->where);
+ &dt->format_label->where);
return FAILURE;
}
return SUCCESS;
which is equivalent to a single IO element. This function is
mutually recursive with match_io_element(). */
-static match match_io_element (io_kind k, gfc_code **);
+static match match_io_element (io_kind, gfc_code **);
static match
-match_io_iterator (io_kind k, gfc_code ** result)
+match_io_iterator (io_kind k, gfc_code **result)
{
gfc_code *head, *tail, *new;
gfc_iterator *iter;
expression or an IO Iterator. */
static match
-match_io_element (io_kind k, gfc_code ** cpp)
+match_io_element (io_kind k, gfc_code **cpp)
{
gfc_expr *expr;
gfc_code *cp;
case M_READ:
if (expr->symtree->n.sym->attr.intent == INTENT_IN)
{
- gfc_error
- ("Variable '%s' in input list at %C cannot be INTENT(IN)",
- expr->symtree->n.sym->name);
+ gfc_error ("Variable '%s' in input list at %C cannot be "
+ "INTENT(IN)", expr->symtree->n.sym->name);
m = MATCH_ERROR;
}
&& current_dt->io_unit->expr_type == EXPR_VARIABLE
&& gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
{
- gfc_error
- ("Cannot write to internal file unit '%s' at %C inside a "
- "PURE procedure", current_dt->io_unit->symtree->n.sym->name);
+ gfc_error ("Cannot write to internal file unit '%s' at %C "
+ "inside a PURE procedure",
+ current_dt->io_unit->symtree->n.sym->name);
m = MATCH_ERROR;
}
/* Match an I/O list, building gfc_code structures as we go. */
static match
-match_io_list (io_kind k, gfc_code ** head_p)
+match_io_list (io_kind k, gfc_code **head_p)
{
gfc_code *head, *tail, *new;
match m;
/* Attach the data transfer end node. */
static void
-terminate_io (gfc_code * io_code)
+terminate_io (gfc_code *io_code)
{
gfc_code *c;
in resolve_tag and others in gfc_resolve_dt. */
static match
-check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
+ locus *spec_end)
{
#define io_constraint(condition,msg,arg)\
if (condition) \
}
match m;
- gfc_expr * expr;
- gfc_symbol * sym = NULL;
+ gfc_expr *expr;
+ gfc_symbol *sym = NULL;
m = MATCH_YES;
expr = dt->io_unit;
if (expr && expr->expr_type == EXPR_VARIABLE
- && expr->ts.type == BT_CHARACTER)
+ && expr->ts.type == BT_CHARACTER)
{
sym = expr->symtree->n.sym;
&dt->rec->where);
if (dt->namelist != NULL)
- {
- if (gfc_notify_std(GFC_STD_F2003,
- "Fortran 2003: Internal file at %L with namelist",
- &expr->where) == FAILURE)
- m = MATCH_ERROR;
- }
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
+ "at %L with namelist", &expr->where)
+ == FAILURE)
+ m = MATCH_ERROR;
+ }
io_constraint (dt->advance != NULL,
"ADVANCE tag at %L is incompatible with internal file",
if (expr && expr->ts.type != BT_CHARACTER)
{
- io_constraint (gfc_pure (NULL)
- && (k == M_READ || k == M_WRITE),
+ io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
"IO UNIT in %s statement at %C must be "
"an internal file in a PURE procedure",
io_kind_name (k));
if (k != M_READ)
{
- io_constraint (dt->end,
- "END tag not allowed with output at %L",
+ io_constraint (dt->end, "END tag not allowed with output at %L",
&dt->end_where);
- io_constraint (dt->eor,
- "EOR tag not allowed with output at %L",
+ io_constraint (dt->eor, "EOR tag not allowed with output at %L",
&dt->eor_where);
io_constraint (k != M_READ && dt->size,
"List directed format(*) is not allowed with a "
"ADVANCE=specifier at %L.", &expr->where);
- io_constraint (dt->format_expr == NULL
- && dt->format_label == NULL
- && dt->namelist == NULL,
+ io_constraint (dt->format_expr == NULL && dt->format_label == NULL
+ && dt->namelist == NULL,
"the ADVANCE=specifier at %L must appear with an "
"explicit format expression", &expr->where);
}
#undef io_constraint
+
/* Match a READ, WRITE or PRINT statement. */
static match
{
/* Before issuing an error for a malformed 'print (1,*)' type of
error, check for a default-char-expr of the form ('(I0)'). */
-
if (k == M_PRINT && m == MATCH_YES)
{
/* Reset current locus to get the initial '(' in an expression. */
/* Free a gfc_inquire structure. */
void
-gfc_free_inquire (gfc_inquire * inquire)
+gfc_free_inquire (gfc_inquire *inquire)
{
if (inquire == NULL)
gfc_free_expr (inquire->iolength);
gfc_free_expr (inquire->convert);
gfc_free_expr (inquire->strm_pos);
-
gfc_free (inquire);
}
#define RETM if (m != MATCH_NO) return m;
static match
-match_inquire_element (gfc_inquire * inquire)
+match_inquire_element (gfc_inquire *inquire)
{
match m;
if (inquire->unit != NULL && inquire->file != NULL)
{
- gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
- " UNIT specifiers", &loc);
+ gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
+ "UNIT specifiers", &loc);
goto cleanup;
}
if (inquire->unit == NULL && inquire->file == NULL)
{
- gfc_error ("INQUIRE statement at %L requires either FILE or"
- " UNIT specifier", &loc);
+ gfc_error ("INQUIRE statement at %L requires either FILE or "
+ "UNIT specifier", &loc);
goto cleanup;
}
/* Resolve everything in a gfc_inquire structure. */
try
-gfc_resolve_inquire (gfc_inquire * inquire)
+gfc_resolve_inquire (gfc_inquire *inquire)
{
-
RESOLVE_TAG (&tag_unit, inquire->unit);
RESOLVE_TAG (&tag_file, inquire->file);
RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
/* Intrinsic function resolution.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
#include "gfortran.h"
#include "intrinsic.h"
-
/* Given printf-like arguments, return a stable version of the result string.
We already have a working, optimized string hashing table in the form of
tree ident;
va_start (ap, format);
- vsnprintf (temp_name, sizeof(temp_name), format, ap);
+ vsnprintf (temp_name, sizeof (temp_name), format, ap);
va_end (ap);
- temp_name[sizeof(temp_name)-1] = 0;
+ temp_name[sizeof (temp_name) - 1] = 0;
ident = get_identifier (temp_name);
return IDENTIFIER_POINTER (ident);
void
-gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
+gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
{
f->ts = a->ts;
if (f->ts.type == BT_COMPLEX)
f->ts.type = BT_REAL;
- f->value.function.name =
- gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_access (gfc_expr * f, gfc_expr * name ATTRIBUTE_UNUSED,
- gfc_expr * mode ATTRIBUTE_UNUSED)
+gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
+ gfc_expr *mode ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
- f->value.function.name = PREFIX("access_func");
+ f->value.function.name = PREFIX ("access_func");
}
void
-gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
+gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
void
-gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
+gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
{
f->ts.type = BT_REAL;
f->ts.kind = x->ts.kind;
- f->value.function.name =
- gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
void
-gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
- f->ts.kind = gfc_kind_max (i,j);
+ f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
- f->value.function.name = gfc_get_string ("__and_%c%d",
- gfc_type_letter (i->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
void
-gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
}
/* The resolved name is only used for specific intrinsics where
the return kind is the same as the arg kind. */
- f->value.function.name =
- gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
+gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_aint (f, a, NULL);
}
void
-gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
+gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
- mask->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
+ mask->ts.kind);
}
void
-gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
gfc_typespec ts;
/* The resolved name is only used for specific intrinsics where
the return kind is the same as the arg kind. */
- f->value.function.name =
- gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
+ a->ts.kind);
}
void
-gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
+gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_anint (f, a, NULL);
}
void
-gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
+gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts = mask->ts;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
- mask->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
+ mask->ts.kind);
}
void
-gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
+gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
void
-gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
+gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
void
-gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
- gfc_expr * y ATTRIBUTE_UNUSED)
+gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
/* Resolve the BESYN and BESJN intrinsics. */
void
-gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
+gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
{
gfc_typespec ts;
void
-gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
+gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
{
f->ts.type = BT_LOGICAL;
f->ts.kind = gfc_default_logical_kind;
-
- f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
- pos->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
}
void
-gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_CHARACTER;
- f->ts.kind = (kind == NULL) ? gfc_default_character_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__char_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
+gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
}
void
-gfc_resolve_chdir_sub (gfc_code * c)
+gfc_resolve_chdir_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_chmod (gfc_expr * f, gfc_expr * name ATTRIBUTE_UNUSED,
- gfc_expr * mode ATTRIBUTE_UNUSED)
+gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
+ gfc_expr *mode ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
- f->value.function.name = PREFIX("chmod_func");
+ f->value.function.name = PREFIX ("chmod_func");
}
void
-gfc_resolve_chmod_sub (gfc_code * c)
+gfc_resolve_chmod_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("chmod_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
+gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
f->ts.type = BT_COMPLEX;
- f->ts.kind = (kind == NULL) ? gfc_default_real_kind
- : mpz_get_si (kind->value.integer);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
if (y == NULL)
- f->value.function.name =
- gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
- gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
+ gfc_type_letter (x->ts.type), x->ts.kind);
else
- f->value.function.name =
- gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
- gfc_type_letter (x->ts.type), x->ts.kind,
- gfc_type_letter (y->ts.type), y->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
+ gfc_type_letter (x->ts.type), x->ts.kind,
+ gfc_type_letter (y->ts.type), y->ts.kind);
}
+
void
-gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
+gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
}
+
void
-gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
+gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
int kind;
f->ts.type = BT_COMPLEX;
f->ts.kind = kind;
-
- f->value.function.name =
- gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
- gfc_type_letter (x->ts.type), x->ts.kind,
- gfc_type_letter (y->ts.type), y->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
+ gfc_type_letter (x->ts.type), x->ts.kind,
+ gfc_type_letter (y->ts.type), y->ts.kind);
}
void
-gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
+gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
void
-gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
+gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
+gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
- gfc_type_letter (mask->ts.type), mask->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("count_%d_%c%d"), f->ts.kind,
+ gfc_type_letter (mask->ts.type), mask->ts.kind);
}
void
-gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
- gfc_expr * shift,
- gfc_expr * dim)
+gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+ gfc_expr *dim)
{
int n;
if (dim->ts.kind != shift->ts.kind)
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
- f->value.function.name =
- gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_ctime (gfc_expr * f, gfc_expr * time)
+gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
gfc_typespec ts;
gfc_convert_type (time, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ctime"));
+ f->value.function.name = gfc_get_string (PREFIX ("ctime"));
}
void
-gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
+gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_REAL;
f->ts.kind = gfc_default_double_kind;
- f->value.function.name =
- gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p)
+gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
- gfc_convert_type(p, &a->ts, 2);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ gfc_convert_type (a, &p->ts, 2);
}
- f->value.function.name =
- gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
}
void
-gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
+gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
temp.value.op.op2 = b;
gfc_type_convert_binary (&temp);
f->ts = temp.ts;
-
- f->value.function.name =
- gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("dot_product_%c%d"),
+ gfc_type_letter (f->ts.type), f->ts.kind);
}
void
-gfc_resolve_dprod (gfc_expr * f,
- gfc_expr * a ATTRIBUTE_UNUSED,
- gfc_expr * b ATTRIBUTE_UNUSED)
+gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+ gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts.kind = gfc_default_double_kind;
f->ts.type = BT_REAL;
-
f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
}
void
-gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
- gfc_expr * shift,
- gfc_expr * boundary,
- gfc_expr * dim)
+gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
+ gfc_expr *boundary, gfc_expr *dim)
{
int n;
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
- f->value.function.name =
- gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
- array->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
+ array->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
+gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
+gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
-
f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
}
void
-gfc_resolve_fdate (gfc_expr * f)
+gfc_resolve_fdate (gfc_expr *f)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = gfc_default_character_kind;
- f->value.function.name = gfc_get_string (PREFIX("fdate"));
+ f->value.function.name = gfc_get_string (PREFIX ("fdate"));
}
void
-gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__floor%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
+gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (n->ts.kind != f->ts.kind)
gfc_convert_type (n, &f->ts, 2);
- f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
}
void
-gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
+gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
void
-gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
+gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
f->value.function.name = gfc_get_string ("<intrinsic>");
void
-gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getcwd"));
+ f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
}
void
-gfc_resolve_getgid (gfc_expr * f)
+gfc_resolve_getgid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getgid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getgid"));
}
void
-gfc_resolve_getpid (gfc_expr * f)
+gfc_resolve_getpid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getpid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getpid"));
}
void
-gfc_resolve_getuid (gfc_expr * f)
+gfc_resolve_getuid (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("getuid"));
+ f->value.function.name = gfc_get_string (PREFIX ("getuid"));
}
+
void
-gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
}
+
void
-gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
+gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
void
-gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
- gfc_expr * pos ATTRIBUTE_UNUSED,
- gfc_expr * len ATTRIBUTE_UNUSED)
+gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
+ gfc_expr *len ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
void
-gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
- gfc_expr * pos ATTRIBUTE_UNUSED)
+gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
void
-gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
-
f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}
void
-gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
+gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
{
gfc_resolve_nint (f, a, NULL);
}
void
-gfc_resolve_ierrno (gfc_expr * f)
+gfc_resolve_ierrno (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
}
void
-gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
/* If the kind of i and j are different, then g77 cross-promoted the
kinds to the largest value. The Fortran 95 standard requires the
kinds to match. */
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
f->ts = i->ts;
void
-gfc_resolve_index_func (gfc_expr * f, gfc_expr * str,
- ATTRIBUTE_UNUSED gfc_expr * sub_str, gfc_expr * back)
+gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
+ gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
{
gfc_typespec ts;
gfc_convert_type (back, &ts, 2);
}
- f->value.function.name =
- gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
}
void
-gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
- a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_int2 (gfc_expr * f, gfc_expr * a)
+gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 2;
-
- f->value.function.name =
- gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
- a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_int8 (gfc_expr * f, gfc_expr * a)
+gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
-
- f->value.function.name =
- gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
- a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_long (gfc_expr * f, gfc_expr * a)
+gfc_resolve_long (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
-
- f->value.function.name =
- gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
- a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
+gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
}
void
-gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
+gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
- f->value.function.name =
- gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
}
void
-gfc_resolve_rshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
+gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
- f->value.function.name =
- gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
}
void
-gfc_resolve_lshift (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
+gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
f->ts = i->ts;
- f->value.function.name =
- gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
}
void
-gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
- gfc_expr * size)
+gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
int s_kind;
s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
f->ts = i->ts;
- f->value.function.name =
- gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
+ f->value.function.name
+ = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
}
void
-gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
- ATTRIBUTE_UNUSED gfc_expr * s)
+gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
+ gfc_expr *s ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
-
- f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
}
void
-gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
- gfc_expr * dim)
+gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char lbound[] = "__lbound";
void
-gfc_resolve_len (gfc_expr * f, gfc_expr * string)
+gfc_resolve_len (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string ("__len_%d_i%d", string->ts.kind,
- gfc_default_integer_kind);
+ f->value.function.name
+ = gfc_get_string ("__len_%d_i%d", string->ts.kind,
+ gfc_default_integer_kind);
}
void
-gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
+gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
- gfc_expr * p2 ATTRIBUTE_UNUSED)
+gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+ gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
}
void
-gfc_resolve_log (gfc_expr * f, gfc_expr * x)
+gfc_resolve_log (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
+gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
+ x->ts.kind);
}
void
-gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_LOGICAL;
- f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
- : mpz_get_si (kind->value.integer);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
f->rank = a->rank;
- f->value.function.name =
- gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
+gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
{
if (size->ts.kind < gfc_index_integer_kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_index_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("malloc"));
+ f->value.function.name = gfc_get_string (PREFIX ("malloc"));
}
void
-gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
+gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
- f->value.function.name =
- gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
+ f->ts.kind);
}
static void
-gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
+gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
{
gfc_actual_arglist *a;
for (a = args->next; a; a = a->next)
{
if (a->expr->ts.kind > f->ts.kind)
- f->ts.kind = a->expr->ts.kind;
+ f->ts.kind = a->expr->ts.kind;
}
/* Convert all parameters to the required kind. */
for (a = args; a; a = a->next)
{
if (a->expr->ts.kind != f->ts.kind)
- gfc_convert_type (a->expr, &f->ts, 2);
+ gfc_convert_type (a->expr, &f->ts, 2);
}
- f->value.function.name =
- gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
+ f->value.function.name
+ = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
}
void
-gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
+gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__max_%c%d", f, args);
}
void
-gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
int i, j, idim;
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
- j++;
+ j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
else
name = "maxloc";
- f->value.function.name =
- gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
int i, j, idim;
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
- j++;
+ j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
else
name = "maxval";
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_mclock (gfc_expr * f)
+gfc_resolve_mclock (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = PREFIX("mclock");
+ f->value.function.name = PREFIX ("mclock");
}
void
-gfc_resolve_mclock8 (gfc_expr * f)
+gfc_resolve_mclock8 (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
- f->value.function.name = PREFIX("mclock8");
+ f->value.function.name = PREFIX ("mclock8");
}
void
-gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
- gfc_expr * fsource ATTRIBUTE_UNUSED,
- gfc_expr * mask ATTRIBUTE_UNUSED)
+gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
+ gfc_expr *fsource ATTRIBUTE_UNUSED,
+ gfc_expr *mask ATTRIBUTE_UNUSED)
{
if (tsource->ts.type == BT_CHARACTER)
check_charlen_present (tsource);
f->ts = tsource->ts;
- f->value.function.name =
- gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
- tsource->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
+ tsource->ts.kind);
}
void
-gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
+gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__min_%c%d", f, args);
}
void
-gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
int i, j, idim;
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
- j++;
+ j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
else
name = "minloc";
- f->value.function.name =
- gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
int i, j, idim;
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
- j++;
+ j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
else
name = "minval";
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p)
+gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
- gfc_convert_type(p, &a->ts, 2);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ gfc_convert_type (a, &p->ts, 2);
}
- f->value.function.name =
- gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
}
void
-gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p)
+gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
f->ts.type = a->ts.type;
if (p != NULL)
if (p != NULL && a->ts.kind != p->ts.kind)
{
if (a->ts.kind == gfc_kind_max (a,p))
- gfc_convert_type(p, &a->ts, 2);
+ gfc_convert_type (p, &a->ts, 2);
else
- gfc_convert_type(a, &p->ts, 2);
+ gfc_convert_type (a, &p->ts, 2);
}
- f->value.function.name =
- gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
+ f->ts.kind);
}
void
-gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
- f->value.function.name =
- gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
- a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
+ a->ts.kind);
}
void
-gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
- f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
- : mpz_get_si (kind->value.integer);
-
- f->value.function.name =
- gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
+ f->ts.kind = (kind == NULL)
+ ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
+ f->value.function.name
+ = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
}
void
-gfc_resolve_not (gfc_expr * f, gfc_expr * i)
+gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
void
-gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
- f->ts.kind = gfc_kind_max (i,j);
+ f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
- f->value.function.name = gfc_get_string ("__or_%c%d",
- gfc_type_letter (i->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
void
-gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
- gfc_expr * vector ATTRIBUTE_UNUSED)
+gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
+ gfc_expr *vector ATTRIBUTE_UNUSED)
{
f->ts = array->ts;
f->rank = 1;
if (mask->rank != 0)
f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX("pack_char")
- : PREFIX("pack"));
+ ? PREFIX ("pack_char") : PREFIX ("pack"));
else
{
/* We convert mask to default logical only in the scalar case.
}
f->value.function.name = (array->ts.type == BT_CHARACTER
- ? PREFIX("pack_s_char")
- : PREFIX("pack_s"));
+ ? PREFIX ("pack_s_char") : PREFIX ("pack_s"));
}
}
void
-gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask)
{
const char *name;
else
name = "product";
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
+gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_REAL;
if (kind != NULL)
f->ts.kind = mpz_get_si (kind->value.integer);
else
- f->ts.kind = (a->ts.type == BT_COMPLEX) ?
- a->ts.kind : gfc_default_real_kind;
+ f->ts.kind = (a->ts.type == BT_COMPLEX)
+ ? a->ts.kind : gfc_default_real_kind;
- f->value.function.name =
- gfc_get_string ("__real_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
+gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
{
f->ts.type = BT_REAL;
f->ts.kind = a->ts.kind;
- f->value.function.name =
- gfc_get_string ("__real_%d_%c%d", f->ts.kind,
- gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
+ gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
- gfc_expr * p2 ATTRIBUTE_UNUSED)
+gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+ gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
}
void
-gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
- gfc_expr * ncopies ATTRIBUTE_UNUSED)
+gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
+ gfc_expr *ncopies ATTRIBUTE_UNUSED)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
void
-gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
- gfc_expr * pad ATTRIBUTE_UNUSED,
- gfc_expr * order ATTRIBUTE_UNUSED)
+gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
+ gfc_expr *pad ATTRIBUTE_UNUSED,
+ gfc_expr *order ATTRIBUTE_UNUSED)
{
mpz_t rank;
int kind;
case 10:
case 16:
if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
- f->value.function.name =
- gfc_get_string (PREFIX("reshape_%c%d"),
- gfc_type_letter (source->ts.type), source->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("reshape_%c%d"),
+ gfc_type_letter (source->ts.type),
+ source->ts.kind);
else
- f->value.function.name =
- gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
+ f->value.function.name
+ = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
break;
default:
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX("reshape_char")
- : PREFIX("reshape"));
+ ? PREFIX ("reshape_char") : PREFIX ("reshape"));
break;
}
void
-gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
+gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec;
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;
if (i->ts.kind != gfc_c_int_kind)
{
gfc_typespec ts;
-
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
-
gfc_convert_type_warn (i, &ts, 2, 0);
}
void
-gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
- gfc_expr * set ATTRIBUTE_UNUSED,
- gfc_expr * back ATTRIBUTE_UNUSED)
+gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
+ gfc_expr *set ATTRIBUTE_UNUSED,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
+gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
{
t1->ts = t0->ts;
- t1->value.function.name =
- gfc_get_string (PREFIX("secnds"));
+ t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
}
void
-gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
+gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, gfc_expr *i)
{
f->ts = x->ts;
if (i->ts.kind != 4)
{
gfc_typespec ts;
-
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
-
gfc_convert_type_warn (i, &ts, 2, 0);
}
void
-gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
+gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->rank = 1;
- f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
f->shape = gfc_get_shape (1);
mpz_init_set_ui (f->shape[0], array->rank);
+ f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
}
void
-gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
+gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
- f->value.function.name =
- gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
}
void
-gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
+gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &f->ts, 2);
- f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
+ f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
}
else
- f->value.function.name = gfc_get_string (PREFIX("signal_func"));
+ f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
if (number->ts.kind != gfc_c_int_kind)
gfc_convert_type (number, &f->ts, 2);
void
-gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
+gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
+gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
int k;
gfc_actual_arglist *prec, *tiny, *emin_1;
prec->next = emin_1;
f->value.function.actual->next = prec;
-
}
void
-gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
- gfc_expr * dim,
- gfc_expr * ncopies)
+gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
+ gfc_expr *ncopies)
{
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
f->rank = source->rank + 1;
if (source->rank == 0)
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX("spread_char_scalar")
- : PREFIX("spread_scalar"));
+ ? PREFIX ("spread_char_scalar")
+ : PREFIX ("spread_scalar"));
else
f->value.function.name = (source->ts.type == BT_CHARACTER
- ? PREFIX("spread_char")
- : PREFIX("spread"));
+ ? PREFIX ("spread_char")
+ : PREFIX ("spread"));
if (dim && gfc_is_constant_expr (dim)
- && ncopies && gfc_is_constant_expr (ncopies)
- && source->shape[0])
+ && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
{
int i, idim;
idim = mpz_get_ui (dim->value.integer);
void
-gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
+gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
/* Resolve the g77 compatibility function STAT AND FSTAT. */
void
-gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
- gfc_expr * a ATTRIBUTE_UNUSED)
+gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
+ gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
}
void
-gfc_resolve_lstat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
- gfc_expr * a ATTRIBUTE_UNUSED)
+gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
+ gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("lstat_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
}
void
-gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
+gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (n->ts.kind != f->ts.kind)
gfc_convert_type (n, &f->ts, 2);
- f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
}
void
-gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
+gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("fgetc"));
+ f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
}
void
-gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
- f->value.function.name = gfc_get_string (PREFIX("fget"));
+ f->value.function.name = gfc_get_string (PREFIX ("fget"));
}
void
-gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
+gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("fputc"));
+ f->value.function.name = gfc_get_string (PREFIX ("fputc"));
}
void
-gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_c_int_kind;
- f->value.function.name = gfc_get_string (PREFIX("fput"));
+ f->value.function.name = gfc_get_string (PREFIX ("fput"));
}
void
-gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
+gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
gfc_typespec ts;
gfc_convert_type (u, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ftell"));
+ f->value.function.name = gfc_get_string (PREFIX ("ftell"));
}
void
-gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
- gfc_expr * mask)
+gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
const char *name;
gfc_resolve_dim_arg (dim);
}
- f->value.function.name =
- gfc_get_string (PREFIX("%s_%c%d"), name,
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), name,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
-gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
- gfc_expr * p2 ATTRIBUTE_UNUSED)
+gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
+ gfc_expr *p2 ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
}
/* Resolve the g77 compatibility function SYSTEM. */
void
-gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("system"));
+ f->value.function.name = gfc_get_string (PREFIX ("system"));
}
void
-gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
+gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
+gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
- f->value.function.name =
- gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
void
-gfc_resolve_time (gfc_expr * f)
+gfc_resolve_time (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("time_func"));
+ f->value.function.name = gfc_get_string (PREFIX ("time_func"));
}
void
-gfc_resolve_time8 (gfc_expr * f)
+gfc_resolve_time8 (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 8;
- f->value.function.name = gfc_get_string (PREFIX("time8_func"));
+ f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
}
void
-gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
- gfc_expr * mold, gfc_expr * size)
+gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
+ gfc_expr *mold, gfc_expr *size)
{
/* TODO: Make this do something meaningful. */
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
void
-gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
+gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
f->ts = matrix->ts;
f->rank = 2;
case 10:
case 16:
switch (matrix->ts.type)
- {
- case BT_REAL:
- case BT_COMPLEX:
- f->value.function.name =
- gfc_get_string (PREFIX("transpose_%c%d"),
- gfc_type_letter (matrix->ts.type),
- matrix->ts.kind);
- break;
-
- case BT_INTEGER:
- case BT_LOGICAL:
+ {
+ case BT_REAL:
+ case BT_COMPLEX:
+ f->value.function.name
+ = gfc_get_string (PREFIX ("transpose_%c%d"),
+ gfc_type_letter (matrix->ts.type),
+ matrix->ts.kind);
+ break;
+
+ case BT_INTEGER:
+ case BT_LOGICAL:
/* Use the integer routines for real and logical cases. This
assumes they all have the same alignment requirements. */
- f->value.function.name =
- gfc_get_string (PREFIX("transpose_i%d"), matrix->ts.kind);
- break;
-
- default:
- f->value.function.name = PREFIX("transpose");
- break;
- }
+ f->value.function.name
+ = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
+ break;
+
+ default:
+ f->value.function.name = PREFIX ("transpose");
+ break;
+ }
break;
default:
f->value.function.name = (matrix->ts.type == BT_CHARACTER
- ? PREFIX("transpose_char")
- : PREFIX("transpose"));
+ ? PREFIX ("transpose_char")
+ : PREFIX ("transpose"));
break;
}
}
void
-gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
+gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
void
-gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
- gfc_expr * dim)
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
static char ubound[] = "__ubound";
/* Resolve the g77 compatibility function UMASK. */
void
-gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
+gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
{
f->ts.type = BT_INTEGER;
f->ts.kind = n->ts.kind;
- f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
+ f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
}
/* Resolve the g77 compatibility function UNLINK. */
void
-gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = 4;
- f->value.function.name = gfc_get_string (PREFIX("unlink"));
+ f->value.function.name = gfc_get_string (PREFIX ("unlink"));
}
void
-gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
+gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
{
gfc_typespec ts;
gfc_convert_type (unit, &ts, 2);
}
- f->value.function.name = gfc_get_string (PREFIX("ttynam"));
+ f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
}
void
-gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
- gfc_expr * field ATTRIBUTE_UNUSED)
+gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
+ gfc_expr *field ATTRIBUTE_UNUSED)
{
f->ts = vector->ts;
f->rank = mask->rank;
- f->value.function.name =
- gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
- vector->ts.type == BT_CHARACTER ? "_char" : "");
+ f->value.function.name
+ = gfc_get_string (PREFIX ("unpack%d%s"), field->rank > 0 ? 1 : 0,
+ vector->ts.type == BT_CHARACTER ? "_char" : "");
}
void
-gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
- gfc_expr * set ATTRIBUTE_UNUSED,
- gfc_expr * back ATTRIBUTE_UNUSED)
+gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
+ gfc_expr *set ATTRIBUTE_UNUSED,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
void
-gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
f->ts.type = i->ts.type;
- f->ts.kind = gfc_kind_max (i,j);
+ f->ts.kind = gfc_kind_max (i, j);
if (i->ts.kind != j->ts.kind)
{
- if (i->ts.kind == gfc_kind_max (i,j))
- gfc_convert_type(j, &i->ts, 2);
+ if (i->ts.kind == gfc_kind_max (i, j))
+ gfc_convert_type (j, &i->ts, 2);
else
- gfc_convert_type(i, &j->ts, 2);
+ gfc_convert_type (i, &j->ts, 2);
}
- f->value.function.name = gfc_get_string ("__xor_%c%d",
- gfc_type_letter (i->ts.type),
- f->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
}
/* Intrinsic subroutine resolution. */
void
-gfc_resolve_alarm_sub (gfc_code * c)
+gfc_resolve_alarm_sub (gfc_code *c)
{
const char *name;
gfc_expr *seconds, *handler, *status;
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
- name = gfc_get_string (PREFIX("alarm_sub_int"));
+ name = gfc_get_string (PREFIX ("alarm_sub_int"));
}
else
- name = gfc_get_string (PREFIX("alarm_sub"));
+ name = gfc_get_string (PREFIX ("alarm_sub"));
if (seconds->ts.kind != gfc_c_int_kind)
gfc_convert_type (seconds, &ts, 2);
}
void
-gfc_resolve_cpu_time (gfc_code * c)
+gfc_resolve_cpu_time (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("cpu_time_%d"),
- c->ext.actual->expr->ts.kind);
+ name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_mvbits (gfc_code * c)
+gfc_resolve_mvbits (gfc_code *c)
{
const char *name;
int kind;
-
kind = c->ext.actual->expr->ts.kind;
- name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
-
+ name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_random_number (gfc_code * c)
+gfc_resolve_random_number (gfc_code *c)
{
const char *name;
int kind;
kind = c->ext.actual->expr->ts.kind;
if (c->ext.actual->expr->rank == 0)
- name = gfc_get_string (PREFIX("random_r%d"), kind);
+ name = gfc_get_string (PREFIX ("random_r%d"), kind);
else
- name = gfc_get_string (PREFIX("arandom_r%d"), kind);
+ name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_rename_sub (gfc_code * c)
+gfc_resolve_rename_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_kill_sub (gfc_code * c)
+gfc_resolve_kill_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_link_sub (gfc_code * c)
+gfc_resolve_link_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_symlnk_sub (gfc_code * c)
+gfc_resolve_symlnk_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* G77 compatibility subroutines etime() and dtime(). */
void
-gfc_resolve_etime_sub (gfc_code * c)
+gfc_resolve_etime_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("etime_sub"));
+ name = gfc_get_string (PREFIX ("etime_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
void
-gfc_resolve_itime (gfc_code * c)
+gfc_resolve_itime (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol
- (gfc_get_string (PREFIX("itime_i%d"),
- gfc_default_integer_kind));
+ c->resolved_sym
+ = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
+ gfc_default_integer_kind));
}
void
-gfc_resolve_idate (gfc_code * c)
+gfc_resolve_idate (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol
- (gfc_get_string (PREFIX("idate_i%d"),
- gfc_default_integer_kind));
+ c->resolved_sym
+ = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
+ gfc_default_integer_kind));
}
void
-gfc_resolve_ltime (gfc_code * c)
+gfc_resolve_ltime (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol
- (gfc_get_string (PREFIX("ltime_i%d"),
- gfc_default_integer_kind));
+ c->resolved_sym
+ = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
+ gfc_default_integer_kind));
}
void
-gfc_resolve_gmtime (gfc_code * c)
+gfc_resolve_gmtime (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol
- (gfc_get_string (PREFIX("gmtime_i%d"),
- gfc_default_integer_kind));
+ c->resolved_sym
+ = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
+ gfc_default_integer_kind));
}
/* G77 compatibility subroutine second(). */
void
-gfc_resolve_second_sub (gfc_code * c)
+gfc_resolve_second_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("second_sub"));
+ name = gfc_get_string (PREFIX ("second_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_sleep_sub (gfc_code * c)
+gfc_resolve_sleep_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* G77 compatibility function srand(). */
void
-gfc_resolve_srand (gfc_code * c)
+gfc_resolve_srand (gfc_code *c)
{
const char *name;
- name = gfc_get_string (PREFIX("srand"));
+ name = gfc_get_string (PREFIX ("srand"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the getarg intrinsic subroutine. */
void
-gfc_resolve_getarg (gfc_code * c)
+gfc_resolve_getarg (gfc_code *c)
{
const char *name;
int kind;
-
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("getarg_i%d"), kind);
+ name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the getcwd intrinsic subroutine. */
void
-gfc_resolve_getcwd_sub (gfc_code * c)
+gfc_resolve_getcwd_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the get_command intrinsic subroutine. */
void
-gfc_resolve_get_command (gfc_code * c)
+gfc_resolve_get_command (gfc_code *c)
{
const char *name;
int kind;
-
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("get_command_i%d"), kind);
+ name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the get_command_argument intrinsic subroutine. */
void
-gfc_resolve_get_command_argument (gfc_code * c)
+gfc_resolve_get_command_argument (gfc_code *c)
{
const char *name;
int kind;
-
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
+ name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the get_environment_variable intrinsic subroutine. */
void
-gfc_resolve_get_environment_variable (gfc_code * code)
+gfc_resolve_get_environment_variable (gfc_code *code)
{
const char *name;
int kind;
-
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
+ name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
void
-gfc_resolve_signal_sub (gfc_code * c)
+gfc_resolve_signal_sub (gfc_code *c)
{
const char *name;
gfc_expr *number, *handler, *status;
{
if (handler->ts.kind != gfc_c_int_kind)
gfc_convert_type (handler, &ts, 2);
- name = gfc_get_string (PREFIX("signal_sub_int"));
+ name = gfc_get_string (PREFIX ("signal_sub_int"));
}
else
- name = gfc_get_string (PREFIX("signal_sub"));
+ name = gfc_get_string (PREFIX ("signal_sub"));
if (number->ts.kind != gfc_c_int_kind)
gfc_convert_type (number, &ts, 2);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the SYSTEM intrinsic subroutine. */
void
-gfc_resolve_system_sub (gfc_code * c)
+gfc_resolve_system_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("system_sub"));
+ name = gfc_get_string (PREFIX ("system_sub"));
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
void
-gfc_resolve_system_clock (gfc_code * c)
+gfc_resolve_system_clock (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+ name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the EXIT intrinsic subroutine. */
void
-gfc_resolve_exit (gfc_code * c)
+gfc_resolve_exit (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("exit_i%d"), kind);
+ name = gfc_get_string (PREFIX ("exit_i%d"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
/* Resolve the FLUSH intrinsic subroutine. */
void
-gfc_resolve_flush (gfc_code * c)
+gfc_resolve_flush (gfc_code *c)
{
const char *name;
gfc_typespec ts;
ts.type = BT_INTEGER;
ts.kind = gfc_default_integer_kind;
n = c->ext.actual->expr;
- if (n != NULL
- && n->ts.kind != ts.kind)
+ if (n != NULL && n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
- name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
+ name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_free (gfc_code * c)
+gfc_resolve_free (gfc_code *c)
{
gfc_typespec ts;
gfc_expr *n;
if (n->ts.kind != ts.kind)
gfc_convert_type (n, &ts, 2);
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
}
void
-gfc_resolve_ctime_sub (gfc_code * c)
+gfc_resolve_ctime_sub (gfc_code *c)
{
gfc_typespec ts;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ctime_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
}
void
-gfc_resolve_fdate_sub (gfc_code * c)
+gfc_resolve_fdate_sub (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
}
void
-gfc_resolve_gerror (gfc_code * c)
+gfc_resolve_gerror (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
}
void
-gfc_resolve_getlog (gfc_code * c)
+gfc_resolve_getlog (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
}
void
-gfc_resolve_hostnm_sub (gfc_code * c)
+gfc_resolve_hostnm_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_perror (gfc_code * c)
+gfc_resolve_perror (gfc_code *c)
{
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
}
/* Resolve the STAT and FSTAT intrinsic subroutines. */
void
-gfc_resolve_stat_sub (gfc_code * c)
+gfc_resolve_stat_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_lstat_sub (gfc_code * c)
+gfc_resolve_lstat_sub (gfc_code *c)
{
const char *name;
-
- name = gfc_get_string (PREFIX("lstat_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_fstat_sub (gfc_code * c)
+gfc_resolve_fstat_sub (gfc_code *c)
{
const char *name;
gfc_expr *u;
ts = &c->ext.actual->next->expr->ts;
if (u->ts.kind != ts->kind)
gfc_convert_type (u, ts, 2);
- name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
+ name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_fgetc_sub (gfc_code * c)
+gfc_resolve_fgetc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
}
if (st != NULL)
- name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
+ name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
else
- name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_fget_sub (gfc_code * c)
+gfc_resolve_fget_sub (gfc_code *c)
{
const char *name;
gfc_expr *st;
st = c->ext.actual->next->expr;
if (st != NULL)
- name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
+ name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
else
- name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_fputc_sub (gfc_code * c)
+gfc_resolve_fputc_sub (gfc_code *c)
{
const char *name;
gfc_typespec ts;
}
if (st != NULL)
- name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
+ name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
else
- name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_fput_sub (gfc_code * c)
+gfc_resolve_fput_sub (gfc_code *c)
{
const char *name;
gfc_expr *st;
st = c->ext.actual->next->expr;
if (st != NULL)
- name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
+ name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
else
- name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
+ name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_ftell_sub (gfc_code * c)
+gfc_resolve_ftell_sub (gfc_code *c)
{
const char *name;
gfc_expr *unit;
gfc_convert_type (unit, &ts, 2);
}
- name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
+ name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
-gfc_resolve_ttynam_sub (gfc_code * c)
+gfc_resolve_ttynam_sub (gfc_code *c)
{
gfc_typespec ts;
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
}
/* Resolve the UMASK intrinsic subroutine. */
void
-gfc_resolve_umask_sub (gfc_code * c)
+gfc_resolve_umask_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Resolve the UNLINK intrinsic subroutine. */
void
-gfc_resolve_unlink_sub (gfc_code * c)
+gfc_resolve_unlink_sub (gfc_code *c)
{
const char *name;
int kind;
else
kind = gfc_default_integer_kind;
- name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
+ name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
do most of the work. */
match
-gfc_match_st_label (gfc_st_label ** label)
+gfc_match_st_label (gfc_st_label **label)
{
locus old_loc;
match m;
A '%' character is a mandatory space. */
int
-gfc_match_strings (mstring * a)
+gfc_match_strings (mstring *a)
{
mstring *p, *best_match;
int no_match, c, possibles;
if (*p->mp == ' ')
{
/* Space matches 1+ whitespace(s). */
- if ((gfc_current_form == FORM_FREE)
- && gfc_is_whitespace (c))
+ if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
continue;
p->mp++;
if (!ISALPHA (c))
{
if (gfc_error_flag_test() == 0)
- gfc_error ("Invalid character in name at %C");
+ gfc_error ("Invalid character in name at %C");
gfc_current_locus = old_loc;
return MATCH_NO;
}
old_loc = gfc_current_locus;
c = gfc_next_char ();
}
- while (ISALNUM (c)
- || c == '_'
- || (gfc_option.flag_dollar_ok && c == '$'));
+ while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
gfc_current_locus = old_loc;
pointer if successful. */
match
-gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
+gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
if (host_assoc)
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
- ? MATCH_ERROR : MATCH_YES;
+ ? MATCH_ERROR : MATCH_YES;
if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
return MATCH_ERROR;
match
-gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
+gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
{
gfc_symtree *st;
match m;
if (m == MATCH_YES)
{
if (st)
- *matched_symbol = st->n.sym;
+ *matched_symbol = st->n.sym;
else
- *matched_symbol = NULL;
+ *matched_symbol = NULL;
}
else
*matched_symbol = NULL;
return m;
}
+
/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
in matchexp.c. */
match
-gfc_match_intrinsic_op (gfc_intrinsic_op * result)
+gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
gfc_intrinsic_op op;
the equals sign is seen. */
match
-gfc_match_iterator (gfc_iterator * iter, int init_flag)
+gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
- /* Match the start of an iterator without affecting the symbol
- table. */
+ /* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
m = gfc_match (" %n =", name);
case 'l':
case 'n':
case 's':
- (void)va_arg (argp, void **);
+ (void) va_arg (argp, void **);
break;
case 'e':
when just after having encountered a simple IF statement. This code
is really duplicate with parts of the gfc_match_if code, but this is
*much* easier. */
+
static match
match_arithmetic_if (void)
{
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: arithmetic IF statement at %C") == FAILURE)
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF statement "
+ "at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
static match match_simple_where (void);
match
-gfc_match_if (gfc_statement * if_type)
+gfc_match_if (gfc_statement *if_type)
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
{
if (n == MATCH_YES)
{
- gfc_error
- ("Block label not appropriate for arithmetic IF statement "
- "at %C");
-
+ gfc_error ("Block label not appropriate for arithmetic IF "
+ "statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
{
-
gfc_free_expr (expr);
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: arithmetic IF statement at %C")
- == FAILURE)
- return MATCH_ERROR;
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF "
+ "statement at %C") == FAILURE)
+ return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
{
new_st.op = EXEC_IF;
new_st.expr = expr;
-
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
if (n == MATCH_YES)
{
gfc_error ("Block label is not appropriate IF statement at %C");
-
gfc_free_expr (expr);
return MATCH_ERROR;
}
/* All else has failed, so give up. See if any of the matchers has
stored an error message of some sort. */
- if (gfc_error_check () == 0)
+ if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
/* Free a gfc_iterator structure. */
void
-gfc_free_iterator (gfc_iterator * iter, int flag)
+gfc_free_iterator (gfc_iterator *iter, int flag)
{
-
if (iter == NULL)
return;
}
/* match an optional comma, if no comma is found a space is obligatory. */
- if (gfc_match_char(',') != MATCH_YES
- && gfc_match ("% ") != MATCH_YES)
+ if (gfc_match_char(',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
return MATCH_NO;
/* See if we have a DO WHILE. */
match
gfc_match_exit (void)
{
-
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
match
gfc_match_cycle (void)
{
-
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
{
m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
- goto cleanup;
+ goto cleanup;
if (m == MATCH_YES && cnt > 5)
{
}
if (m == MATCH_NO)
- {
- /* Try a character constant. */
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
- goto syntax;
- }
+ {
+ /* Try a character constant. */
+ m = gfc_match_expr (&e);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ goto syntax;
+ }
if (gfc_match_eos () != MATCH_YES)
- goto syntax;
+ goto syntax;
}
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
- gfc_ascii_statement (st));
+ gfc_ascii_statement (st));
goto cleanup;
}
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: PAUSE statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C")
== FAILURE)
m = MATCH_ERROR;
}
match
gfc_match_continue (void)
{
-
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
- return MATCH_ERROR;
+ return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: ASSIGN statement at %C")
+ {
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
+ expr->symtree->n.sym->attr.assign = 1;
- new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label = label;
- new_st.expr = expr;
- return MATCH_YES;
- }
+ new_st.op = EXEC_LABEL_ASSIGN;
+ new_st.label = label;
+ new_st.expr = expr;
+ return MATCH_YES;
+ }
}
return MATCH_NO;
}
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: Assigned GOTO statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
if (head == NULL)
{
- gfc_error (
- "Statement label list in GOTO at %C cannot be empty");
+ gfc_error ("Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
new_st.block = head;
/* Frees a list of gfc_alloc structures. */
void
-gfc_free_alloc_list (gfc_alloc * p)
+gfc_free_alloc_list (gfc_alloc *p)
{
gfc_alloc *q;
goto cleanup;
if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
"PURE procedure");
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
- gfc_error
- ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
- "INTENT(IN)", stat->symtree->n.sym->name);
+ gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
+ "be INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
- gfc_error
- ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
+ "for a PURE procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
- gfc_error("STAT expression at %C must be a variable");
+ gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
- gfc_error
- ("Illegal variable in NULLIFY at %C for a PURE procedure");
+ gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
goto cleanup;
if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error
- ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
+ "for a PURE procedure");
goto cleanup;
}
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;
}
if (gfc_current_form == FORM_FREE)
{
/* The following are valid, so we can't require a blank after the
- RETURN keyword:
- return+1
- return(1) */
+ RETURN keyword:
+ return+1
+ return(1) */
c = gfc_peek_char ();
if (ISALPHA (c) || ISDIGIT (c))
- return MATCH_NO;
+ return MATCH_NO;
}
m = gfc_match (" %e%t", &e);
gfc_enclosing_unit (&s);
if (s == COMP_PROGRAM
&& gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
- "main program at %C") == FAILURE)
+ "main program at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
new_st.next = c = gfc_get_code ();
c->op = EXEC_SELECT;
- sprintf (name, "_result_%s",sym->name);
+ sprintf (name, "_result_%s", sym->name);
gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
select_sym = select_st->n.sym;
{
gfc_symtree *st;
static int serial = 0;
- char mangled_name[GFC_MAX_SYMBOL_LEN+1];
+ char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
if (from_module)
{
/* A use associated common block is only needed to correctly layout
the variables it contains. */
- snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+ snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *t;
gfc_array_spec *as;
- gfc_equiv * e1, * e2;
+ gfc_equiv *e1, *e2;
match m;
gfc_gsymbol *gsym;
gsym = gfc_get_gsymbol (name);
if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
{
- gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
- name);
+ gfc_error ("Symbol '%s' at %C is already an external symbol that "
+ "is not COMMON", name);
goto cleanup;
}
{
if (gfc_current_ns->is_block_data)
{
- gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C");
+ gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
+ "at %C");
}
t = &gfc_current_ns->blank_common;
if (t->head == NULL)
/* Derived type names must have the SEQUENCE attribute. */
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
{
- gfc_error
- ("Derived type variable in COMMON at %C does not have the "
- "SEQUENCE attribute");
+ gfc_error ("Derived type variable in COMMON at %C does not "
+ "have the SEQUENCE attribute");
goto cleanup;
}
tail = sym;
/* Deal with an optional array specification after the
- symbol name. */
+ symbol name. */
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
{
if (as->type != AS_EXPLICIT)
{
- gfc_error
- ("Array specification for symbol '%s' in COMMON at %C "
- "must be explicit", sym->name);
+ gfc_error ("Array specification for symbol '%s' in COMMON "
+ "at %C must be explicit", sym->name);
goto cleanup;
}
if (sym->attr.pointer)
{
- gfc_error
- ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
- sym->name);
+ gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
+ "POINTER array", sym->name);
goto cleanup;
}
if (sym->attr.in_equivalence)
{
for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
- {
- for (e2 = e1; e2; e2 = e2->eq)
- if (e2->expr->symtree->n.sym == sym)
+ {
+ for (e2 = e1; e2; e2 = e2->eq)
+ if (e2->expr->symtree->n.sym == sym)
goto equiv_found;
continue;
{
other = e2->expr->symtree->n.sym;
if (other->common_head
- && other->common_head != sym->common_head)
+ && other->common_head != sym->common_head)
{
gfc_error ("Symbol '%s', in COMMON block '%s' at "
"%C is being indirectly equivalenced to "
"another COMMON block '%s'",
- sym->name,
- sym->common_head->name,
+ sym->name, sym->common_head->name,
other->common_head->name);
goto cleanup;
}
/* Free a namelist structure. */
void
-gfc_free_namelist (gfc_namelist * name)
+gfc_free_namelist (gfc_namelist *name)
{
gfc_namelist *n;
{
if (group_name->ts.type != BT_UNKNOWN)
{
- gfc_error
- ("Namelist group name '%s' at %C already has a basic type "
- "of %s", group_name->name, gfc_typename (&group_name->ts));
+ gfc_error ("Namelist group name '%s' at %C already has a basic "
+ "type of %s", group_name->name,
+ gfc_typename (&group_name->ts));
return MATCH_ERROR;
}
&& gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name)
- == FAILURE)
+ == FAILURE)
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Assumed size array '%s' in namelist '%s' at "
- "%C is not allowed", sym->name, group_name->name);
+ "%C is not allowed", sym->name, group_name->name);
gfc_error_check ();
}
if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
- "namelist '%s' at %C is an extension.",
- sym->name, group_name->name) == FAILURE)
+ && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
+ "namelist '%s' at %C is an extension.",
+ sym->name, group_name->name) == FAILURE)
gfc_error_check ();
nl = gfc_get_namelist ();
do this. */
void
-gfc_free_equiv (gfc_equiv * eq)
+gfc_free_equiv (gfc_equiv *eq)
{
-
if (eq == NULL)
return;
gfc_free_equiv (eq->eq);
gfc_free_equiv (eq->next);
-
gfc_free_expr (eq->expr);
gfc_free (eq);
}
for (ref = set->expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
{
- gfc_error
- ("Array reference in EQUIVALENCE at %C cannot be an "
- "array section");
+ gfc_error ("Array reference in EQUIVALENCE at %C cannot "
+ "be an array section");
goto cleanup;
}
sym = set->expr->symtree->n.sym;
- if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
- == FAILURE)
+ if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.in_common)
{
gfc_error ("Attempt to indirectly overlap COMMON "
"blocks %s and %s by EQUIVALENCE at %C",
- sym->common_head->name,
- common_head->name);
+ sym->common_head->name, common_head->name);
goto cleanup;
}
sym->attr.in_common = 1;
return MATCH_ERROR;
}
+
/* Check that a statement function is not recursive. This is done by looking
for the statement function symbol(sym) by looking recursively through its
expression(e). If a reference to sym is found, true is returned.
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
{
- if (sym->name == arg->name
- || recursive_stmt_fcn (arg->expr, sym))
+ if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
return true;
}
/* Catch recursion via other statement functions. */
if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
- && e->symtree->n.sym->value
- && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
+ && e->symtree->n.sym->value
+ && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
return true;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
case EXPR_OP:
if (recursive_stmt_fcn (e->value.op.op1, sym)
- || recursive_stmt_fcn (e->value.op.op2, sym))
+ || recursive_stmt_fcn (e->value.op.op2, sym))
return true;
break;
for (i = 0; i < ref->u.ar.dimen; i++)
{
if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
- || recursive_stmt_fcn (ref->u.ar.end[i], sym)
- || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
+ || recursive_stmt_fcn (ref->u.ar.end[i], sym)
+ || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
return true;
}
break;
case REF_SUBSTRING:
if (recursive_stmt_fcn (ref->u.ss.start, sym)
- || recursive_stmt_fcn (ref->u.ss.end, sym))
+ || recursive_stmt_fcn (ref->u.ss.end, sym))
return true;
break;
if (recursive_stmt_fcn (expr, sym))
{
- gfc_error ("Statement function at %L is recursive",
- &expr->where);
+ gfc_error ("Statement function at %L is recursive", &expr->where);
return MATCH_ERROR;
}
/* Free a single case structure. */
static void
-free_case (gfc_case * p)
+free_case (gfc_case *p)
{
if (p->low == p->high)
p->high = NULL;
/* Free a list of case structures. */
void
-gfc_free_case_list (gfc_case * p)
+gfc_free_case_list (gfc_case *p)
{
gfc_case *q;
/* Match a single case selector. */
static match
-match_case_selector (gfc_case ** cp)
+match_case_selector (gfc_case **cp)
{
gfc_case *c;
match m;
if (m == MATCH_ERROR)
goto cleanup;
}
-
else
{
m = gfc_match_init_expr (&c->low);
/* Match a WHERE statement. */
match
-gfc_match_where (gfc_statement * st)
+gfc_match_where (gfc_statement *st)
{
gfc_expr *expr;
match m0, m;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
-
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
/* Free a list of FORALL iterators. */
void
-gfc_free_forall_iterator (gfc_forall_iterator * iter)
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
{
gfc_forall_iterator *next;
while (iter)
{
next = iter->next;
-
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->stride);
-
gfc_free (iter);
iter = next;
}
<var> = <start>:<end>[:<stride>][, <scalar mask>] */
static match
-match_forall_iterator (gfc_forall_iterator ** result)
+match_forall_iterator (gfc_forall_iterator **result)
{
gfc_forall_iterator *iter;
locus where;
/* Make sure that potential internal function references in the
mask do not get messed up. */
if (iter->var
- && iter->var->expr_type == EXPR_VARIABLE
- && iter->var->symtree->n.sym->refs == 1)
+ && iter->var->expr_type == EXPR_VARIABLE
+ && iter->var->symtree->n.sym->refs == 1)
iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
gfc_current_locus = where;
/* Match the header of a FORALL statement. */
static match
-match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
gfc_forall_iterator *head, *tail, *new;
gfc_expr *msk;
return MATCH_ERROR;
}
-/* Match the rest of a simple FORALL statement that follows an IF statement.
- */
+/* Match the rest of a simple FORALL statement that follows an
+ IF statement. */
static match
match_simple_forall (void)
/* Match a FORALL statement. */
match
-gfc_match_forall (gfc_statement * st)
+gfc_match_forall (gfc_statement *st)
{
gfc_forall_iterator *head;
gfc_expr *mask;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_FORALL_BLOCK;
-
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
-
return MATCH_YES;
}
new_st.expr = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
-
new_st.block->op = EXEC_FORALL;
new_st.block->next = c;
projects / platform / upstream / linaro-gcc.git / commitdiff