diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2010-03-03 16:12:40 +0100 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2010-03-03 16:12:40 +0100 |
| commit | d1039125cf7fb52634de26fe93cd892e15db2756 (patch) | |
| tree | 8870cecc1afada0f27f66dd2049bafb6ec5f3eb5 /gcc/fortran/resolve.c | |
| parent | 2ba34efc55ba605a18f858dc0d043ea90a07042a (diff) | |
| download | gcc-d1039125cf7fb52634de26fe93cd892e15db2756.zip gcc-d1039125cf7fb52634de26fe93cd892e15db2756.tar.gz gcc-d1039125cf7fb52634de26fe93cd892e15db2756.tar.bz2 | |
re PR fortran/43169 ([OOP] gfortran rejects pure procedure with select type construct)
2010-03-03 Janus Weil <janus@gcc.gnu.org>
PR fortran/43169
* resolve.c (resolve_code): Correctly set gfc_current_ns for
EXEC_SELECT_TYPE.
(gfc_impure_variable): Make it work with sub-namespaces (BLOCK etc).
(gfc_pure): Ditto.
2010-03-03 Janus Weil <janus@gcc.gnu.org>
PR fortran/43169
* gfortran.dg/impure_assignment_3.f90: New.
From-SVN: r157196
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 38 |
1 files changed, 31 insertions, 7 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8de0de6..10d8807 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8012,6 +8012,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_DO: gfc_resolve_omp_do_blocks (code, ns); break; + case EXEC_SELECT_TYPE: + gfc_current_ns = code->ext.ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = ns; + break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; @@ -11670,12 +11675,19 @@ int gfc_impure_variable (gfc_symbol *sym) { gfc_symbol *proc; + gfc_namespace *ns; if (sym->attr.use_assoc || sym->attr.in_common) return 1; - if (sym->ns != gfc_current_ns) - return !sym->attr.function; + /* Check if the symbol's ns is inside the pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + if (ns == sym->ns) + break; + if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) + return 1; + } proc = sym->ns->proc_name; if (sym->attr.dummy && gfc_pure (proc) @@ -11691,18 +11703,30 @@ gfc_impure_variable (gfc_symbol *sym) } -/* Test whether a symbol is pure or not. For a NULL pointer, checks the - symbol of the current procedure. */ +/* Test whether a symbol is pure or not. For a NULL pointer, checks if the + current namespace is inside a pure procedure. */ int gfc_pure (gfc_symbol *sym) { symbol_attribute attr; + gfc_namespace *ns; if (sym == NULL) - sym = gfc_current_ns->proc_name; - if (sym == NULL) - return 0; + { + /* Check if the current namespace or one of its parents + belongs to a pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return 0; + attr = sym->attr; + if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental)) + return 1; + } + return 0; + } attr = sym->attr; |