This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[fortran-dev] constructor work, part I
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Wed, 23 Dec 2009 17:37:01 +0100
- Subject: [fortran-dev] constructor work, part I
Hi all,
as mentioned a couple of times before, I'd like to get rid of linked lists for
constructurs. Instead, a more suitable tree structure should be used.
Due to some uncertainty which tree structure would be the most suitable one,
I'd like to postpone that question for the time being and start with some
preparations:
(a) define an API that hides the implementation details of constructors
(b) apply the API everywhere where the linked-list implementation is used
directly
(c) reimplement the API functions using a different data structure
The initial implementation of (a) would of course use the linked-list to be
compatible with the code not transformed yet and obviously re-use what's
already available. After (b) is complete, one may or may not hide the
constructor-structure and make it an opaque pointer in gfc_expr (remove
con_by_offset while at it). Then, one could initially implement (c) with a
splay-tree, which already is provided by libiberty. If issues are found due to
properties of the splaying, one could replace it with a red-black tree later.
The attach patch against fortran-dev starts (a) and (b) together;
constructor.h defines an initial version of a constructor API (a smoothed out
version of what we already have and barely use), constructor.c implements it
with by mainly re-using the existing functions.
To see if it actually works as intended, arith.c, decl.c and expr.c were
already transformed to use the new API. As some inserts on tail-pointers were
replaced by list traversals from begining to end, compile-time performance
degraded a bit (testcase gfortran.dg/initialization_21.f90 times out).
2009-12-23 Daniel Franke <franke.daniel@gmail.com>
* constructor.h: New.
* constructor.c: New.
* Make-lang.in: Add new files to F95_PARSER_OBJS.
* arith.c (reducy_unary): Use constructor API.
(reduce_binary_ac): Likewise.
(reduce_binary_ca): Likewise.
(reduce_binary_aa): Likewise.
* decl.c (add_init_expr_to_sym): Likewise.
(build_struct): Likewise.
* expr.c (gfc_is_constant_expr): Likewise.
(simplify_constructor): Likewise.
(find_array_element): Likewise.
(find_component_ref): Likewise.
(find_array_section): Likewise.
(simplify_const_ref): Likewise.
(scalarize_intrinsic_call): Likewise.
(check_alloc_comp_init): Likewise.
(gfc_default_initializer): Likewise.
(gfc_traverse_expr): Likewise.
Bootstrapped and regression tested on i686-pc-linux-gnu. One performance
regression (gfortran.dg/initialization_21.f90). Ok for fortran-dev?
Cheers
Daniel
Index: constructor.c
===================================================================
--- constructor.c (revision 0)
+++ constructor.c (revision 0)
@@ -0,0 +1,180 @@
+/* Array and structure constructors
+ Copyright (C) 2009
+ Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "gfortran.h"
+#include "constructor.h"
+
+gfc_expr *
+gfc_build_array_expr (gfc_typespec *ts, locus *where)
+{
+ gfc_expr *e;
+
+ gcc_assert (ts);
+ gcc_assert (where);
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->value.constructor = NULL;
+ e->rank = 1;
+ e->shape = NULL;
+ e->ts = *ts;
+ e->where = *where;
+
+ return e;
+}
+
+gfc_expr *
+gfc_build_structure_constructor_expr (gfc_typespec *ts, locus *where)
+{
+ gfc_expr *e;
+
+ gcc_assert (ts);
+ gcc_assert (where);
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_STRUCTURE;
+ e->value.constructor = NULL;
+ e->ts = *ts;
+ e->where = *where;
+
+ return e;
+}
+
+
+
+gfc_constructor *
+gfc_constructor_get (void)
+{
+ return gfc_get_constructor();
+}
+
+
+gfc_constructor *
+gfc_constructor_copy (gfc_constructor *ctor)
+{
+ return gfc_copy_constructor (ctor);
+}
+
+
+void
+gfc_constructor_free (gfc_constructor *ctor)
+{
+ gfc_free_constructor (ctor);
+}
+
+
+gfc_constructor *
+gfc_constructor_append (gfc_constructor **head, gfc_constructor *c)
+{
+ gcc_assert (head);
+ if (*head)
+ {
+ gfc_constructor *i = *head;
+ while (i->next)
+ i = i->next;
+
+ i->next = c;
+ }
+ else
+ *head = c;
+
+ return c;
+}
+
+gfc_constructor *
+gfc_constructor_append_expr (gfc_constructor **ctor, gfc_expr *e, locus *where)
+{
+ gfc_constructor *c = gfc_constructor_get ();
+ c->expr = e;
+ if (where)
+ c->where = *where;
+
+ return gfc_constructor_append (ctor, c);
+}
+
+
+gfc_constructor *
+gfc_constructor_insert (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+ gfc_expr *e ATTRIBUTE_UNUSED,
+ int n ATTRIBUTE_UNUSED)
+{
+ gcc_assert (0);
+ return NULL;
+}
+
+
+gfc_constructor *
+gfc_constructor_lookup (gfc_constructor *ctor, int n)
+{
+ gcc_assert (n >= 0);
+
+ while (ctor && n-- > 0)
+ ctor = ctor->next;
+
+ return ctor;
+}
+
+
+int
+gfc_constructor_expr_foreach (gfc_constructor *ctor, int(*f)(gfc_expr *))
+{
+ gfc_constructor_iterator c;
+ int res;
+
+ for (gfc_constructor_first(ctor, &c); c.cur; gfc_constructor_next(&c))
+ if ((res = f(c.cur->expr)) != 0)
+ return res;
+
+ return 0;
+}
+
+void
+gfc_constructor_swap (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+ int n ATTRIBUTE_UNUSED, int m ATTRIBUTE_UNUSED)
+{
+ gcc_assert (0);
+}
+
+
+
+gfc_constructor *
+gfc_constructor_first (gfc_constructor *ctor,
+ gfc_constructor_iterator *iter)
+{
+ if (iter)
+ {
+ iter->head = ctor;
+ iter->cur = ctor;
+ }
+
+ return iter ? iter->cur : NULL;
+}
+
+
+gfc_constructor *
+gfc_constructor_next (gfc_constructor_iterator *iter)
+{
+ if (iter && iter->cur)
+ iter->cur = iter->cur->next;
+
+ return iter ? iter->cur : NULL;
+}
Index: constructor.h
===================================================================
--- constructor.h (revision 0)
+++ constructor.h (revision 0)
@@ -0,0 +1,97 @@
+/* Array and structure constructors
+ Copyright (C) 2009
+ Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#ifndef GFC_CONSTRUCTOR_H
+#define GFC_CONSTRUCTOR_H
+
+#include "gfortran.h"
+
+/* Create an array constructor expression. The constructor
+ starts with zero elements, new elements should be inserted
+ by gfc_constructor_expr_insert().
+ TODO: remove array.c (gfc_start_constructor). */
+gfc_expr *gfc_build_array_expr (gfc_typespec *ts, locus *where);
+
+gfc_expr *gfc_build_structure_constructor_expr (gfc_typespec *ts, locus *where);
+
+
+/* Get a new constructor structure.
+ TODO: remove array.c (gfc_get_constructor). */
+gfc_constructor *gfc_constructor_get (void);
+
+
+/* Copy a constructor structure.
+ TODO: remove array.c (gfc_copy_constructor). */
+gfc_constructor *gfc_constructor_copy (gfc_constructor *ctor);
+
+
+/* Free a gfc_constructor structure.
+ TODO: remove array.c (gfc_free_constructor). */
+void gfc_constructor_free (gfc_constructor *);
+
+
+/* Given an constructor structure, append the expression node onto
+ the constructor. Returns the constructor node appended.
+ TODO: remove array.c (gfc_append_constructor). */
+gfc_constructor *gfc_constructor_append (gfc_constructor **ctor, gfc_constructor *c);
+
+gfc_constructor *gfc_constructor_append_expr (gfc_constructor **ctor, gfc_expr *e, locus *where);
+
+
+/* Given an constructor structure, place the expression node at position.
+ Returns the constructor node inserted. */
+gfc_constructor *gfc_constructor_insert (gfc_constructor *ctor, gfc_expr *e, int n);
+
+
+/* Given an array constructor expression and an element number (starting
+ at zero), return a pointer to the array element. NULL is returned if
+ the size of the array has been exceeded. The expression node returned
+ remains a part of the array and should not be freed.
+ TODO: remove array.c (gfc_get_array_element)
+ TODO: remove expr.c (find_array_element). */
+gfc_constructor *gfc_constructor_lookup (gfc_constructor *ctor, int n);
+
+
+int gfc_constructor_expr_foreach (gfc_constructor *ctor, int(*)(gfc_expr *));
+
+
+void gfc_constructor_swap (gfc_constructor *ctor, int n, int m);
+
+
+
+
+typedef struct
+{
+ gfc_constructor *head;
+ gfc_constructor *cur;
+}
+gfc_constructor_iterator;
+
+
+/* Get the first expression in the constructure structure.
+ Returns NULL if there is no such expression. */
+gfc_constructor *gfc_constructor_first (gfc_constructor *ctor,
+ gfc_constructor_iterator *iter);
+
+/* Get the next expression in the constructure structure.
+ Returns NULL if there is no next expression. */
+gfc_constructor *gfc_constructor_next (gfc_constructor_iterator *iter);
+
+#endif /* GFC_CONSTRUCTOR_H */
Index: Make-lang.in
===================================================================
--- Make-lang.in (revision 155425)
+++ Make-lang.in (working copy)
@@ -53,8 +53,8 @@ fortran-warn = $(STRICT_WARN)
# from the parse tree to GENERIC
F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
- fortran/check.o fortran/cpp.o fortran/data.o fortran/decl.o \
- fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \
+ fortran/check.o fortran/constructor.o fortran/cpp.o fortran/data.o \
+ fortran/decl.o fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \
fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \
fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
@@ -300,7 +300,7 @@ fortran.stagefeedback: stageprofile-star
# TODO: Add dependencies on the backend/tree header files
$(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \
- fortran/intrinsic.h fortran/match.h \
+ fortran/intrinsic.h fortran/match.h fortran/constructor.h \
fortran/parse.h fortran/arith.h fortran/target-memory.h \
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
Index: arith.c
===================================================================
--- arith.c (revision 155425)
+++ arith.c (working copy)
@@ -30,6 +30,7 @@ along with GCC; see the file COPYING3.
#include "gfortran.h"
#include "arith.h"
#include "target-memory.h"
+#include "constructor.h"
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
It's easily implemented with a few calls though. */
@@ -1249,7 +1250,8 @@ static arith
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor *head;
+ gfc_constructor_iterator c;
gfc_expr *r;
arith rc;
@@ -1257,31 +1259,25 @@ reduce_unary (arith (*eval) (gfc_expr *,
return eval (op, result);
rc = ARITH_OK;
- head = gfc_copy_constructor (op->value.constructor);
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op->value.constructor);
+ for (gfc_constructor_first (head, &c); c.cur; gfc_constructor_next (&c))
{
- rc = reduce_unary (eval, c->expr, &r);
+ rc = reduce_unary (eval, c.cur->expr, &r);
if (rc != ARITH_OK)
break;
- gfc_replace_expr (c->expr, r);
+ gfc_replace_expr (c.cur->expr, r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ r = gfc_build_array_expr (&head->expr->ts, &op->where);
r->shape = gfc_copy_shape (op->shape, op->rank);
-
- r->ts = head->expr->ts;
- r->where = op->where;
r->rank = op->rank;
-
+ r->value.constructor = head;
*result = r;
}
@@ -1293,39 +1289,33 @@ static arith
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor *head;
+ gfc_constructor_iterator c;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
head = gfc_copy_constructor (op1->value.constructor);
- rc = ARITH_OK;
-
- for (c = head; c; c = c->next)
+ for (gfc_constructor_first (head, &c); c.cur; gfc_constructor_next (&c))
{
- if (c->expr->expr_type == EXPR_CONSTANT)
- rc = eval (c->expr, op2, &r);
+ if (c.cur->expr->expr_type == EXPR_CONSTANT)
+ rc = eval (c.cur->expr, op2, &r);
else
- rc = reduce_binary_ac (eval, c->expr, op2, &r);
+ rc = reduce_binary_ac (eval, c.cur->expr, op2, &r);
if (rc != ARITH_OK)
break;
- gfc_replace_expr (c->expr, r);
+ gfc_replace_expr (c.cur->expr, r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ r = gfc_build_array_expr (&head->expr->ts, &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
@@ -1337,39 +1327,33 @@ static arith
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor *head;
+ gfc_constructor_iterator c;
gfc_expr *r;
- arith rc;
-
- head = gfc_copy_constructor (op2->value.constructor);
- rc = ARITH_OK;
+ arith rc = ARITH_OK;
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op2->value.constructor);
+ for (gfc_constructor_first (head, &c); c.cur; gfc_constructor_next (&c))
{
- if (c->expr->expr_type == EXPR_CONSTANT)
- rc = eval (op1, c->expr, &r);
+ if (c.cur->expr->expr_type == EXPR_CONSTANT)
+ rc = eval (op1, c.cur->expr, &r);
else
- rc = reduce_binary_ca (eval, op1, c->expr, &r);
+ rc = reduce_binary_ca (eval, op1, c.cur->expr, &r);
if (rc != ARITH_OK)
break;
- gfc_replace_expr (c->expr, r);
+ gfc_replace_expr (c.cur->expr, r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ r = gfc_build_array_expr (&head->expr->ts, &op2->where);
r->shape = gfc_copy_shape (op2->shape, op2->rank);
-
- r->ts = head->expr->ts;
- r->where = op2->where;
r->rank = op2->rank;
-
+ r->value.constructor = head;
*result = r;
}
@@ -1386,52 +1370,39 @@ static arith
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *d, *head;
+ gfc_constructor *head;
+ gfc_constructor_iterator c, d;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op1->value.constructor);
-
- rc = ARITH_OK;
- d = op2->value.constructor;
+ if (gfc_check_conformance (op1, op2,
+ "elemental binary operation") != SUCCESS)
+ return ARITH_INCOMMENSURATE;
- if (gfc_check_conformance (op1, op2, "elemental binary operation")
- != SUCCESS)
- rc = ARITH_INCOMMENSURATE;
- else
+ head = gfc_copy_constructor (op1->value.constructor);
+ for (gfc_constructor_first (head, &c),
+ gfc_constructor_first (op2->value.constructor, &d);
+ c.cur && d.cur;
+ gfc_constructor_next (&c), gfc_constructor_next (&d))
{
- for (c = head; c; c = c->next, d = d->next)
- {
- if (d == NULL)
- {
- rc = ARITH_INCOMMENSURATE;
- break;
- }
-
- rc = reduce_binary (eval, c->expr, d->expr, &r);
- if (rc != ARITH_OK)
- break;
-
- gfc_replace_expr (c->expr, r);
- }
+ rc = reduce_binary (eval, c.cur->expr, d.cur->expr, &r);
+ if (rc != ARITH_OK)
+ break;
- if (d != NULL)
- rc = ARITH_INCOMMENSURATE;
+ gfc_replace_expr (c.cur->expr, r);
}
+ if (c.cur || d.cur)
+ rc = ARITH_INCOMMENSURATE;
+
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ r = gfc_build_array_expr (&head->expr->ts, &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
Index: decl.c
===================================================================
--- decl.c (revision 155425)
+++ decl.c (working copy)
@@ -25,7 +25,7 @@ along with GCC; see the file COPYING3.
#include "match.h"
#include "parse.h"
#include "flags.h"
-
+#include "constructor.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
@@ -1299,19 +1299,21 @@ add_init_expr_to_sym (const char *name,
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
- gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
+ gfc_constructor_iterator c;
+
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
- for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, -1);
+ for (gfc_constructor_first (init->value.constructor, &c);
+ c.cur; gfc_constructor_next (&c))
+ gfc_set_constant_character_len (len, c.cur->expr, -1);
}
}
}
@@ -1335,37 +1337,23 @@ add_init_expr_to_sym (const char *name,
if (init->ts.is_iso_c)
sym->ts.f90_type = init->ts.f90_type;
}
-
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
mpz_t size;
gfc_expr *array;
- gfc_constructor *c;
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
&& spec_size (sym->as, &size) == SUCCESS
&& mpz_cmp_si (size, 0) > 0)
{
- array = gfc_start_constructor (init->ts.type, init->ts.kind,
- &init->where);
-
- array->value.constructor = c = NULL;
+ array = gfc_build_array_expr (&init->ts, &init->where);
for (n = 0; n < (int)mpz_get_si (size); n++)
- {
- if (array->value.constructor == NULL)
- {
- array->value.constructor = c = gfc_get_constructor ();
- c->expr = init;
- }
- else
- {
- c->next = gfc_get_constructor ();
- c = c->next;
- c->expr = gfc_copy_expr (init);
- }
- }
+ gfc_constructor_append_expr (&array->value.constructor,
+ gfc_copy_expr (init),
+ &init->where);
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
@@ -1451,15 +1439,14 @@ build_struct (const char *name, gfc_char
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
- bool has_ts;
gfc_constructor *ctor = c->initializer->value.constructor;
- has_ts = (c->initializer->ts.u.cl
- && c->initializer->ts.u.cl->length_from_typespec);
-
if (ctor)
{
+ gfc_constructor_iterator ci;
int first_len;
+ bool has_ts = (c->initializer->ts.u.cl
+ && c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
@@ -1468,12 +1455,11 @@ build_struct (const char *name, gfc_char
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
- for (; ctor; ctor = ctor->next)
- {
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
- }
+ for (gfc_constructor_first (ctor, &ci); ci.cur;
+ gfc_constructor_next (&ci))
+ if (ci.cur->expr->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, ci.cur->expr,
+ has_ts ? -1 : first_len);
}
}
}
Index: expr.c
===================================================================
--- expr.c (revision 155425)
+++ expr.c (working copy)
@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3.
#include "arith.h"
#include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
/* Get a new expr node. */
@@ -761,9 +762,8 @@ check_specification_function (gfc_expr *
int
gfc_is_constant_expr (gfc_expr *e)
{
- gfc_constructor *c;
+ gfc_constructor_iterator c;
gfc_actual_arglist *arg;
- int rv;
if (e == NULL)
return 1;
@@ -771,66 +771,53 @@ gfc_is_constant_expr (gfc_expr *e)
switch (e->expr_type)
{
case EXPR_OP:
- rv = (gfc_is_constant_expr (e->value.op.op1)
- && (e->value.op.op2 == NULL
- || gfc_is_constant_expr (e->value.op.op2)));
- break;
+ return (gfc_is_constant_expr (e->value.op.op1)
+ && (e->value.op.op2 == NULL
+ || gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
- rv = 0;
- break;
+ return 0;
case EXPR_FUNCTION:
/* Specification functions are constant. */
if (check_specification_function (e) == MATCH_YES)
- {
- rv = 1;
- break;
- }
+ return 1;
/* Call to intrinsic with at least one argument. */
- rv = 0;
if (e->value.function.isym && e->value.function.actual)
{
for (arg = e->value.function.actual; arg; arg = arg->next)
- {
- if (!gfc_is_constant_expr (arg->expr))
- break;
- }
- if (arg == NULL)
- rv = 1;
+ if (!gfc_is_constant_expr (arg->expr))
+ return 0;
+
+ return 1;
}
- break;
+ else
+ return 0;
case EXPR_CONSTANT:
case EXPR_NULL:
- rv = 1;
- break;
+ return 1;
case EXPR_SUBSTRING:
- rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
- break;
+ return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+ && gfc_is_constant_expr (e->ref->u.ss.end));
case EXPR_STRUCTURE:
- rv = 0;
- for (c = e->value.constructor; c; c = c->next)
- if (!gfc_is_constant_expr (c->expr))
- break;
+ for (gfc_constructor_first (e->value.constructor, &c);
+ c.cur; gfc_constructor_next (&c))
+ if (!gfc_is_constant_expr (c.cur->expr))
+ return 0;
- if (c == NULL)
- rv = 1;
- break;
+ return 1;
case EXPR_ARRAY:
- rv = gfc_constant_ac (e);
- break;
+ return gfc_constant_ac (e);
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+ return 0;
}
-
- return rv;
}
@@ -1002,24 +989,25 @@ simplify_intrinsic_op (gfc_expr *p, int
with gfc_simplify_expr(). */
static gfc_try
-simplify_constructor (gfc_constructor *c, int type)
+simplify_constructor (gfc_constructor *ctor, int type)
{
+ gfc_constructor_iterator c;
gfc_expr *p;
- for (; c; c = c->next)
+ for (gfc_constructor_first (ctor, &c); c.cur; gfc_constructor_next (&c))
{
- if (c->iterator
- && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
- || gfc_simplify_expr (c->iterator->end, type) == FAILURE
- || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
+ if (c.cur->iterator
+ && (gfc_simplify_expr (c.cur->iterator->start, type) == FAILURE
+ || gfc_simplify_expr (c.cur->iterator->end, type) == FAILURE
+ || gfc_simplify_expr (c.cur->iterator->step, type) == FAILURE))
return FAILURE;
- if (c->expr)
+ if (c.cur->expr)
{
/* Try and simplify a copy. Replace the original if successful
but keep going through the constructor at all costs. Not
doing so can make a dog's dinner of complicated things. */
- p = gfc_copy_expr (c->expr);
+ p = gfc_copy_expr (c.cur->expr);
if (gfc_simplify_expr (p, type) == FAILURE)
{
@@ -1027,7 +1015,7 @@ simplify_constructor (gfc_constructor *c
continue;
}
- gfc_replace_expr (c->expr, p);
+ gfc_replace_expr (c.cur->expr, p);
}
}
@@ -1041,7 +1029,6 @@ static gfc_try
find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
gfc_constructor **rval)
{
- unsigned long nelemen;
int i;
mpz_t delta;
mpz_t offset;
@@ -1101,18 +1088,7 @@ find_array_element (gfc_constructor *con
mpz_mul (span, span, tmp);
}
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
- {
- if (cons)
- {
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
- }
- }
+ cons = gfc_constructor_lookup (cons, mpz_get_ui (offset));
depart:
mpz_clear (delta);
@@ -1129,20 +1105,22 @@ depart:
/* Find a component of a structure constructor. */
static gfc_constructor *
-find_component_ref (gfc_constructor *cons, gfc_ref *ref)
+find_component_ref (gfc_constructor *ctor, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
+ gfc_constructor_iterator c;
+ gfc_constructor_first (ctor, &c);
comp = ref->u.c.sym->components;
pick = ref->u.c.component;
while (comp != pick)
{
comp = comp->next;
- cons = cons->next;
+ gfc_constructor_next (&c);
}
- return cons;
+ return c.cur;
}
@@ -1190,7 +1168,8 @@ find_array_section (gfc_expr *expr, gfc_
gfc_expr *step;
gfc_expr *upper;
gfc_expr *lower;
- gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
+ gfc_constructor *vecsub[GFC_MAX_DIMENSIONS];
+ gfc_constructor_iterator ci;
gfc_try t;
t = SUCCESS;
@@ -1254,10 +1233,11 @@ find_array_section (gfc_expr *expr, gfc_
mpz_set (expr->shape[shape_i++], begin->shape[0]);
/* Check bounds. */
- for (c = vecsub[d]; c; c = c->next)
+ gfc_constructor_first (vecsub[d], &ci);
+ for ( ; ci.cur; gfc_constructor_next (&ci))
{
- if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
- || mpz_cmp (c->expr->value.integer,
+ if (mpz_cmp (ci.cur->expr->value.integer, upper->value.integer) > 0
+ || mpz_cmp (ci.cur->expr->value.integer,
lower->value.integer) < 0)
{
gfc_error ("index in dimension %d is out of bounds "
@@ -1366,11 +1346,13 @@ find_array_section (gfc_expr *expr, gfc_
{
gcc_assert(vecsub[d]);
- if (!vecsub[d]->next)
+ gfc_constructor_first (vecsub[d], &ci);
+ gfc_constructor_next (&ci);
+ if (!ci.cur)
vecsub[d] = ref->u.ar.start[d]->value.constructor;
else
{
- vecsub[d] = vecsub[d]->next;
+ vecsub[d] = ci.cur;
incr_ctr = false;
}
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
@@ -1396,13 +1378,16 @@ find_array_section (gfc_expr *expr, gfc_
cons = base;
}
- while (cons && cons->next && mpz_cmp (ptr, index) > 0)
- {
+ gfc_constructor_first (cons, &ci);
+ while (cons && gfc_constructor_lookup (cons, 1)
+ && mpz_cmp (ptr, index) > 0)
+ {
+ cons = gfc_constructor_lookup (cons, 1);
mpz_add_ui (index, index, one);
- cons = cons->next;
}
- gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+ gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (cons->expr), NULL);
}
mpz_clear (ptr);
@@ -1463,6 +1448,7 @@ static gfc_try
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons;
+ gfc_constructor_iterator c;
gfc_expr *newp;
while (p->ref)
@@ -1495,10 +1481,11 @@ simplify_const_ref (gfc_expr *p)
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
cons = p->value.constructor;
- for (; cons; cons = cons->next)
+ for (gfc_constructor_first (p->value.constructor, &c);
+ c.cur; gfc_constructor_next (&c))
{
- cons->expr->ref = gfc_copy_ref (p->ref->next);
- if (simplify_const_ref (cons->expr) == FAILURE)
+ c.cur->expr->ref = gfc_copy_ref (p->ref->next);
+ if (simplify_const_ref (c.cur->expr) == FAILURE)
return FAILURE;
}
@@ -1790,6 +1777,7 @@ scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
gfc_constructor *args[5], *ctor, *new_ctor;
+ gfc_constructor_iterator ci;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
@@ -1813,7 +1801,7 @@ scalarize_intrinsic_call (gfc_expr *e)
old = gfc_copy_expr (e);
- gfc_free_constructor (expr->value.constructor);
+ gfc_constructor_free (expr->value.constructor);
expr->value.constructor = NULL;
expr->ts = old->ts;
@@ -1854,53 +1842,47 @@ scalarize_intrinsic_call (gfc_expr *e)
/* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[array_arg - 1];
- new_ctor = NULL;
- for (; ctor; ctor = ctor->next)
- {
- if (expr->value.constructor == NULL)
- expr->value.constructor
- = new_ctor = gfc_get_constructor ();
+ gfc_constructor_first (args[array_arg - 1], &ci);
+ for (; ci.cur; gfc_constructor_next (&ci))
+ {
+ new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (old), NULL);
+
+ gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+ a = NULL;
+ b = old->value.function.actual;
+ for (i = 0; i < n; i++)
+ {
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
else
{
- new_ctor->next = gfc_get_constructor ();
- new_ctor = new_ctor->next;
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
}
- new_ctor->expr = gfc_copy_expr (old);
- gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
- a = NULL;
- b = old->value.function.actual;
- for (i = 0; i < n; i++)
- {
- if (a == NULL)
- new_ctor->expr->value.function.actual
- = a = gfc_get_actual_arglist ();
- else
- {
- a->next = gfc_get_actual_arglist ();
- a = a->next;
- }
- if (args[i])
- a->expr = gfc_copy_expr (args[i]->expr);
- else
- a->expr = gfc_copy_expr (b->expr);
- b = b->next;
- }
+ if (args[i])
+ a->expr = gfc_copy_expr (args[i]->expr);
+ else
+ a->expr = gfc_copy_expr (b->expr);
- /* Simplify the function calls. If the simplification fails, the
- error will be flagged up down-stream or the library will deal
- with it. */
- gfc_simplify_expr (new_ctor->expr, 0);
-
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = args[i]->next;
-
- for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
- || (args[i] == NULL && args[array_arg - 1] != NULL)))
- goto compliance;
+ b = b->next;
+ }
+
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
+
+ for (i = 0; i < n; i++)
+ if (args[i])
+ args[i] = gfc_constructor_lookup (args[i], 1);
+
+ for (i = 1; i < n; i++)
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
+ goto compliance;
}
free_expr0 (e);
@@ -2040,21 +2022,22 @@ not_numeric:
static gfc_try
check_alloc_comp_init (gfc_expr *e)
{
- gfc_component *c;
- gfc_constructor *ctor;
+ gfc_component *comp;
+ gfc_constructor_iterator ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
gcc_assert (e->ts.type == BT_DERIVED);
- for (c = e->ts.u.derived->components, ctor = e->value.constructor;
- c; c = c->next, ctor = ctor->next)
+ for (comp = e->ts.u.derived->components,
+ gfc_constructor_first (e->value.constructor, &ctor);
+ comp; comp = comp->next, gfc_constructor_next (&ctor))
{
- if (c->attr.allocatable
- && ctor->expr->expr_type != EXPR_NULL)
+ if (comp->attr.allocatable
+ && ctor.cur->expr->expr_type != EXPR_NULL)
{
gfc_error("Invalid initialization expression for ALLOCATABLE "
"component '%s' in structure constructor at %L",
- c->name, &ctor->expr->where);
+ comp->name, &ctor.cur->expr->where);
return FAILURE;
}
}
@@ -3406,45 +3389,35 @@ gfc_check_assign_symbol (gfc_symbol *sym
gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
- gfc_constructor *tail;
gfc_expr *init;
- gfc_component *c;
+ gfc_component *comp;
/* See if we have a default initializer. */
- for (c = ts->u.derived->components; c; c = c->next)
- if (c->initializer || c->attr.allocatable)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
+ if (comp->initializer || comp->attr.allocatable)
break;
- if (!c)
+ if (!comp)
return NULL;
- /* Build the constructor. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_STRUCTURE;
- init->ts = *ts;
- init->where = ts->u.derived->declared_at;
-
- tail = NULL;
- for (c = ts->u.derived->components; c; c = c->next)
+ init = gfc_build_structure_constructor_expr (ts, &ts->u.derived->declared_at);
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
{
- if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_constructor *ctor = gfc_constructor_get();
- if (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
+ if (comp->initializer)
+ ctor->expr = gfc_copy_expr (comp->initializer);
- if (c->attr.allocatable)
+ if (comp->attr.allocatable)
{
- tail->expr = gfc_get_expr ();
- tail->expr->expr_type = EXPR_NULL;
- tail->expr->ts = c->ts;
+ ctor->expr = gfc_get_expr ();
+ ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->ts = comp->ts;
}
+
+ gfc_constructor_append (&init->value.constructor, ctor);
}
+
return init;
}
@@ -3485,7 +3458,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_s
gfc_array_ref ar;
gfc_ref *ref;
gfc_actual_arglist *args;
- gfc_constructor *c;
+ gfc_constructor_iterator c;
int i;
if (!expr)
@@ -3519,19 +3492,20 @@ gfc_traverse_expr (gfc_expr *expr, gfc_s
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- for (c = expr->value.constructor; c; c = c->next)
+ for (gfc_constructor_first (expr->value.constructor, &c); c.cur;
+ gfc_constructor_next (&c))
{
- if (gfc_traverse_expr (c->expr, sym, func, f))
+ if (gfc_traverse_expr (c.cur->expr, sym, func, f))
return true;
- if (c->iterator)
+ if (c.cur->iterator)
{
- if (gfc_traverse_expr (c->iterator->var, sym, func, f))
+ if (gfc_traverse_expr (c.cur->iterator->var, sym, func, f))
return true;
- if (gfc_traverse_expr (c->iterator->start, sym, func, f))
+ if (gfc_traverse_expr (c.cur->iterator->start, sym, func, f))
return true;
- if (gfc_traverse_expr (c->iterator->end, sym, func, f))
+ if (gfc_traverse_expr (c.cur->iterator->end, sym, func, f))
return true;
- if (gfc_traverse_expr (c->iterator->step, sym, func, f))
+ if (gfc_traverse_expr (c.cur->iterator->step, sym, func, f))
return true;
}
}