diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 87 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.texi | 31 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 47 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 30 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 195 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 68 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 27 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 40 | ||||
| -rw-r--r-- | gcc/fortran/trans-common.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 40 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 128 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 51 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 4 |
18 files changed, 555 insertions, 213 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ee13c2f94f5..b26b5c72735 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,90 @@ +2012-05-08 Jan Hubicka <jh@suse.cz> + + * trans-common.c (create_common): Do not fake TREE_ASM_WRITTEN. + * trans-decl.c (gfc_finish_cray_pointee): Likewise. + +2012-05-07 Tobias Burnus <burnus@net-b.de> + + PR fortran/53255 + * resolve.c (resolve_typebound_static): Fix handling + of overridden specific to generic operator. + +2012-05-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/41587 + * decl.c (build_struct): Don't ignore FAILED status. + +2012-05-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/41600 + * trans-array.c (build_array_ref): New static function. + (gfc_conv_array_ref, gfc_get_dataptr_offset): Call it. + * trans-expr.c (gfc_get_vptr_from_expr): New function. + (gfc_conv_derived_to_class): Add a new argument for a caller + supplied vptr and use it if it is not NULL. + (gfc_conv_procedure_call): Add NULL to call to above. + symbol.c (gfc_is_associate_pointer): Return true if symbol is + a class object. + * trans-stmt.c (trans_associate_var): Handle class associate- + names. + * expr.c (gfc_get_variable_expr): Supply the array-spec if + possible. + * trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P + for class types. + * trans.h : Add prototypes for gfc_get_vptr_from_expr and + gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P. + * resolve.c (resolve_variable): For class arrays, ensure that + the target expression has all the necessary _data references. + (resolve_assoc_var): Throw a "not yet implemented" error for + class array selectors that need a temporary. + * match.c (copy_ts_from_selector_to_associate, + select_derived_set_tmp, select_class_set_tmp): New functions. + (select_type_set_tmp): Call one of last two new functions. + (gfc_match_select_type): Copy_ts_from_selector_to_associate is + called if associate-name is typed. + + PR fortran/53191 + * resolve.c (resolve_ref): C614 applied to class expressions. + +2012-05-05 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/49010 + PR fortran/24518 + * intrinsic.texi (MOD, MODULO): Mention sign and magnitude of result. + * simplify.c (gfc_simplify_mod): Use mpfr_fmod. + (gfc_simplify_modulo): Likewise, use copysign to fix the result if + zero. + * trans-intrinsic.c (gfc_conv_intrinsic_mod): Remove fallback as + builtin_fmod is always available. For modulo, call copysign to fix + the result when signed zeros are enabled. + +2012-05-05 Janne Blomqvist <jb@gcc.gnu.org> + + * gfortran.texi (GFORTRAN_TMPDIR): Rename to TMPDIR, explain + algorithm for choosing temp directory. + +2012-05-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/53175 + * resolve.c (resolve_variable): Set public_used + if a private module variable is used in a (public) + specification expression. + * trans-decl.c (gfc_finish_var_decl): Mark those + TREE_PUBLIC. + +2012-05-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/53111 + * resolve.c (resolve_fl_derived): Fix -std=f95 + diagnostic for generic vs. DT names. + +2012-05-03 Tobias Burnus <burnus@net-b.de> + + PR fortran/52864 + * interface.c (compare_parameter_intent): Remove. + (check_intents): Remove call, handle CLASS pointer. + (compare_actual_formal): Handle CLASS pointer. + 2012-04-30 Jan Hubicka <jh@suse.cz> * f95-lang.c (gfc_finish): Update comments. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 4da21c316e3..e166bc916b1 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1658,7 +1658,10 @@ scalar: bool delayed = (gfc_state_stack->sym == c->ts.u.derived) || (!c->ts.u.derived->components && !c->ts.u.derived->attr.zero_comp); - return gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed); + gfc_try t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed); + + if (t != FAILURE) + t = t2; } return t; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d9614413e67..93d5df65455 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3821,6 +3821,9 @@ gfc_get_variable_expr (gfc_symtree *var) e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as + : var->n.sym->as); } return e; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index b1790c6ad5f..96662c49423 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -576,10 +576,10 @@ environment variables. Malformed environment variables are silently ignored. @menu +* TMPDIR:: Directory for scratch files * GFORTRAN_STDIN_UNIT:: Unit number for standard input * GFORTRAN_STDOUT_UNIT:: Unit number for standard output * GFORTRAN_STDERR_UNIT:: Unit number for standard error -* GFORTRAN_TMPDIR:: Directory for scratch files * GFORTRAN_UNBUFFERED_ALL:: Do not buffer I/O for all units. * GFORTRAN_UNBUFFERED_PRECONNECTED:: Do not buffer I/O for preconnected units. * GFORTRAN_SHOW_LOCUS:: Show location for runtime errors @@ -590,6 +590,27 @@ Malformed environment variables are silently ignored. * GFORTRAN_ERROR_BACKTRACE:: Show backtrace on run-time errors @end menu +@node TMPDIR +@section @env{TMPDIR}---Directory for scratch files + +When opening a file with @code{STATUS='SCRATCH'}, GNU Fortran tries to +create the file in one of the potential directories by testing each +directory in the order below. + +@enumerate +@item +The environment variable @env{TMPDIR}, if it exists. + +@item +On the MinGW target, the directory returned by the @code{GetTempPath} +function. Alternatively, on the Cygwin target, the @env{TMP} and +@env{TEMP} environment variables, if they exist, in that order. + +@item +The @code{P_tmpdir} macro if it is defined, otherwise the directory +@file{/tmp}. +@end enumerate + @node GFORTRAN_STDIN_UNIT @section @env{GFORTRAN_STDIN_UNIT}---Unit number for standard input @@ -611,14 +632,6 @@ This environment variable can be used to select the unit number preconnected to standard error. This must be a positive integer. The default value is 0. -@node GFORTRAN_TMPDIR -@section @env{GFORTRAN_TMPDIR}---Directory for scratch files - -This environment variable controls where scratch files are -created. If this environment variable is missing, -GNU Fortran searches for the environment variable @env{TMP}, then @env{TEMP}. -If these are missing, the default is @file{/tmp}. - @node GFORTRAN_UNBUFFERED_ALL @section @env{GFORTRAN_UNBUFFERED_ALL}---Do not buffer I/O on all units diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 2f1d24e6e33..95439c118e4 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2517,7 +2517,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, ? _("actual argument to INTENT = OUT/INOUT") : NULL); - if (f->sym->attr.pointer + if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) && gfc_check_vardef_context (a->expr, true, false, context) == FAILURE) return 0; @@ -2812,25 +2814,6 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) } -/* Given a symbol of a formal argument list and an expression, - return nonzero if their intents are compatible, zero otherwise. */ - -static int -compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual) -{ - 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) - return 0; - - return 1; -} - - /* Given formal and actual argument lists that correspond to one another, check that they are compatible in the sense that intents are not mismatched. */ @@ -2852,25 +2835,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) f_intent = f->sym->attr.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)); - return FAILURE; - } - if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym)) { - 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)); - return FAILURE; - } - - if (f->sym->attr.pointer) + if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) { gfc_error ("Procedure argument at %L is local to a PURE " "procedure and has the POINTER attribute", @@ -2890,7 +2859,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) return FAILURE; } - if (f->sym->attr.pointer) + if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) { gfc_error ("Coindexed actual argument at %L in PURE procedure " "is passed to a POINTER dummy argument", diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 294818e43d0..9bc36d7d415 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -8991,8 +8991,7 @@ cases, the result is of the same type and kind as @var{ARRAY}. @table @asis @item @emph{Description}: -@code{MOD(A,P)} computes the remainder of the division of A by P@. It is -calculated as @code{A - (INT(A/P) * P)}. +@code{MOD(A,P)} computes the remainder of the division of A by P@. @item @emph{Standard}: Fortran 77 and later @@ -9005,14 +9004,16 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL} -@item @var{P} @tab Shall be a scalar of the same type as @var{A} and not -equal to zero +@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL}. +@item @var{P} @tab Shall be a scalar of the same type and kind as @var{A} +and not equal to zero. @end multitable @item @emph{Return value}: -The kind of the return value is the result of cross-promoting -the kinds of the arguments. +The return value is the result of @code{A - (INT(A/P) * P)}. The type +and kind of the return value is the same as that of the arguments. The +returned value has the same sign as A and a magnitude less than the +magnitude of P. @item @emph{Example}: @smallexample @@ -9041,6 +9042,10 @@ end program test_mod @item @code{AMOD(A,P)} @tab @code{REAL(4) A,P} @tab @code{REAL(4)} @tab Fortran 95 and later @item @code{DMOD(A,P)} @tab @code{REAL(8) A,P} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable + +@item @emph{See also}: +@ref{MODULO} + @end table @@ -9066,8 +9071,9 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL} -@item @var{P} @tab Shall be a scalar of the same type and kind as @var{A} +@item @var{A} @tab Shall be a scalar of type @code{INTEGER} or @code{REAL}. +@item @var{P} @tab Shall be a scalar of the same type and kind as @var{A}. +It shall not be zero. @end multitable @item @emph{Return value}: @@ -9080,7 +9086,8 @@ The type and kind of the result are those of the arguments. @item If @var{A} and @var{P} are of type @code{REAL}: @code{MODULO(A,P)} has the value of @code{A - FLOOR (A / P) * P}. @end table -In all cases, if @var{P} is zero the result is processor-dependent. +The returned value has the same sign as P and a magnitude less than +the magnitude of P. @item @emph{Example}: @smallexample @@ -9096,6 +9103,9 @@ program test_modulo end program @end smallexample +@item @emph{See also}: +@ref{MOD} + @end table diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 15edfc36db1..3d119180a73 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5112,6 +5112,78 @@ gfc_match_select (void) } +/* Transfer the selector typespec to the associate name. */ + +static void +copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) +{ + gfc_ref *ref; + gfc_symbol *assoc_sym; + + assoc_sym = associate->symtree->n.sym; + + /* Ensure that any array reference is resolved. */ + gfc_resolve_expr (selector); + + /* At this stage the expression rank and arrayspec dimensions have + not been completely sorted out. We must get the expr2->rank + right here, so that the correct class container is obtained. */ + ref = selector->ref; + while (ref && ref->next) + ref = ref->next; + + if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector)->as + && ref && ref->type == REF_ARRAY) + { + if (ref->u.ar.type == AR_FULL) + selector->rank = CLASS_DATA (selector)->as->rank; + else if (ref->u.ar.type == AR_SECTION) + selector->rank = ref->u.ar.dimen; + else + selector->rank = 0; + } + + if (selector->ts.type != BT_CLASS) + { + /* The correct class container has to be available. */ + if (selector->rank) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_get_array_spec (); + assoc_sym->as->rank = selector->rank; + assoc_sym->as->type = AS_DEFERRED; + } + else + assoc_sym->as = NULL; + + assoc_sym->ts.type = BT_CLASS; + assoc_sym->ts.u.derived = selector->ts.u.derived; + assoc_sym->attr.pointer = 1; + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, + &assoc_sym->as, false); + } + else + { + /* The correct class container has to be available. */ + if (selector->rank) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_get_array_spec (); + assoc_sym->as->rank = selector->rank; + assoc_sym->as->type = AS_DEFERRED; + } + else + assoc_sym->as = NULL; + assoc_sym->ts.type = BT_CLASS; + assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; + assoc_sym->attr.pointer = 1; + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, + &assoc_sym->as, false); + } +} + + /* Push the current selector onto the SELECT TYPE stack. */ static void @@ -5126,64 +5198,103 @@ select_type_push (gfc_symbol *sel) } -/* Set the temporary for the current SELECT TYPE selector. */ +/* Set the temporary for the current derived type SELECT TYPE selector. */ -static void -select_type_set_tmp (gfc_typespec *ts) +static gfc_symtree * +select_derived_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; - if (!ts) + sprintf (name, "__tmp_type_%s", ts->u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + gfc_add_type (tmp->n.sym, ts, NULL); + + /* Copy across the array spec to the selector. */ + if (select_type_stack->selector->ts.type == BT_CLASS + && select_type_stack->selector->attr.class_ok + && (CLASS_DATA (select_type_stack->selector)->attr.dimension + || CLASS_DATA (select_type_stack->selector)->attr.codimension)) { - select_type_stack->tmp = NULL; - return; + tmp->n.sym->attr.dimension + = CLASS_DATA (select_type_stack->selector)->attr.dimension; + tmp->n.sym->attr.codimension + = CLASS_DATA (select_type_stack->selector)->attr.codimension; + tmp->n.sym->as + = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); } + + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + tmp->n.sym->attr.select_type_temporary = 1; + + return tmp; +} + + +/* Set the temporary for the current class SELECT TYPE selector. */ + +static gfc_symtree * +select_class_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; - if (!gfc_type_is_extensible (ts->u.derived)) - return; + if (select_type_stack->selector->ts.type == BT_CLASS + && !select_type_stack->selector->attr.class_ok) + return NULL; - if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); - else - sprintf (name, "__tmp_type_%s", ts->u.derived->name); + sprintf (name, "__tmp_class_%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); -/* Copy across the array spec to the selector, taking care as to - whether or not it is a class object or not. */ +/* Copy across the array spec to the selector. */ if (select_type_stack->selector->ts.type == BT_CLASS - && select_type_stack->selector->attr.class_ok && (CLASS_DATA (select_type_stack->selector)->attr.dimension || CLASS_DATA (select_type_stack->selector)->attr.codimension)) { - if (ts->type == BT_CLASS) - { - CLASS_DATA (tmp->n.sym)->attr.dimension + tmp->n.sym->attr.pointer = 1; + tmp->n.sym->attr.dimension = CLASS_DATA (select_type_stack->selector)->attr.dimension; - CLASS_DATA (tmp->n.sym)->attr.codimension + tmp->n.sym->attr.codimension = CLASS_DATA (select_type_stack->selector)->attr.codimension; - CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec (); - CLASS_DATA (tmp->n.sym)->as - = CLASS_DATA (select_type_stack->selector)->as; - } - else - { - tmp->n.sym->attr.dimension - = CLASS_DATA (select_type_stack->selector)->attr.dimension; - tmp->n.sym->attr.codimension - = CLASS_DATA (select_type_stack->selector)->attr.codimension; - tmp->n.sym->as = gfc_get_array_spec (); - tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as; - } + tmp->n.sym->as + = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); } gfc_set_sym_referenced (tmp->n.sym); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); tmp->n.sym->attr.select_type_temporary = 1; + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as, false); + + return tmp; +} + + +static void +select_type_set_tmp (gfc_typespec *ts) +{ + gfc_symtree *tmp; + + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + + if (!gfc_type_is_extensible (ts->u.derived)) + return; + + /* Logic is a LOT clearer with separate functions for class and derived + type temporaries! There are not many more lines of code either. */ if (ts->type == BT_CLASS) - gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, - &tmp->n.sym->as, false); + tmp = select_class_set_tmp (ts); + else + tmp = select_derived_set_tmp (ts); + + if (tmp == NULL) + return; /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ @@ -5194,7 +5305,7 @@ select_type_set_tmp (gfc_typespec *ts) select_type_stack->tmp = tmp; } - + /* Match a SELECT TYPE statement. */ match @@ -5204,6 +5315,7 @@ gfc_match_select_type (void) match m; char name[GFC_MAX_SYMBOL_LEN]; bool class_array; + gfc_symbol *sym; m = gfc_match_label (); if (m == MATCH_ERROR) @@ -5225,13 +5337,16 @@ gfc_match_select_type (void) m = MATCH_ERROR; goto cleanup; } + + sym = expr1->symtree->n.sym; if (expr2->ts.type == BT_UNKNOWN) - expr1->symtree->n.sym->attr.untyped = 1; + sym->attr.untyped = 1; else - expr1->symtree->n.sym->ts = expr2->ts; - expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; - expr1->symtree->n.sym->attr.referenced = 1; - expr1->symtree->n.sym->attr.class_ok = 1; + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; } else { diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 57da577dfaa..b3a23ed73c9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4904,14 +4904,19 @@ resolve_ref (gfc_expr *expr) { /* F03:C614. */ if (ref->u.c.component->attr.pointer - || ref->u.c.component->attr.proc_pointer) + || ref->u.c.component->attr.proc_pointer + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.pointer)) { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the POINTER " "attribute at %L", &expr->where); return FAILURE; } - else if (ref->u.c.component->attr.allocatable) + else if (ref->u.c.component->attr.allocatable + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.allocatable)) + { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the ALLOCATABLE " @@ -5081,9 +5086,15 @@ resolve_variable (gfc_expr *e) } /* If this is an associate-name, it may be parsed with an array reference - in error even though the target is scalar. Fail directly in this case. */ - if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) - return FAILURE; + in error even though the target is scalar. Fail directly in this case. + TODO Understand why class scalar expressions must be excluded. */ + if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) + { + if (sym->ts.type == BT_CLASS) + gfc_fix_class_refs (e); + if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) + return FAILURE; + } if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); @@ -5124,6 +5135,19 @@ resolve_variable (gfc_expr *e) if (check_assumed_size_reference (sym, e)) return FAILURE; + /* If a PRIVATE variable is used in the specification expression of the + result variable, it might be accessed from outside the module and can + thus not be TREE_PUBLIC() = 0. + TODO: sym->attr.public_used only has to be set for the result variable's + type-parameter expression and not for dummies or automatic variables. + Additionally, it only has to be set if the function is either PUBLIC or + used in a generic interface or TBP; unfortunately, + proc_name->attr.public_used can get set at a later stage. */ + if (specification_expr && sym->attr.access == ACCESS_PRIVATE + && !sym->attr.function && !sym->attr.use_assoc + && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.function) + sym->attr.public_used = 1; + /* Deal with forward references to entries during resolve_code, to satisfy, at least partially, 12.5.2.5. */ if (gfc_current_ns->entries @@ -5647,12 +5671,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, e->value.compcall.actual = NULL; /* If we find a deferred typebound procedure, check for derived types - that an over-riding typebound procedure has not been missed. */ - if (e->value.compcall.tbp->deferred - && e->value.compcall.name - && !e->value.compcall.tbp->non_overridable - && e->value.compcall.base_object - && e->value.compcall.base_object->ts.type == BT_DERIVED) + that an overriding typebound procedure has not been missed. */ + if (e->value.compcall.name + && !e->value.compcall.tbp->non_overridable + && e->value.compcall.base_object + && e->value.compcall.base_object->ts.type == BT_DERIVED) { gfc_symtree *st; gfc_symbol *derived; @@ -7928,7 +7951,7 @@ gfc_type_is_extensible (gfc_symbol *sym) } -/* Resolve an associate name: Resolve target and ensure the type-spec is +/* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ static void @@ -7984,8 +8007,25 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.dimension = 0; return; } - if (target->rank > 0) + + /* We cannot deal with class selectors that need temporaries. */ + if (target->ts.type == BT_CLASS + && gfc_ref_needs_temporary_p (target->ref)) + { + gfc_error ("CLASS selector at %L needs a temporary which is not " + "yet implemented", &target->where); + return; + } + + if (target->ts.type != BT_CLASS && target->rank > 0) sym->attr.dimension = 1; + else if (target->ts.type == BT_CLASS) + gfc_fix_class_refs (target); + + /* The associate-name will have a correct type by now. Make absolutely + sure that it has not picked up a dimension attribute. */ + if (sym->ts.type == BT_CLASS) + sym->attr.dimension = 0; if (sym->attr.dimension) { @@ -12015,6 +12055,8 @@ resolve_fl_derived (gfc_symbol *sym) if (!sym->attr.is_class) gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); if (gen_dt && gen_dt->generic && gen_dt->generic->next + && (!gen_dt->generic->sym->attr.use_assoc + || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of " "function '%s' at %L being the same name as derived " "type at %L", sym->name, diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 706dab440ce..1578db19b94 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4222,7 +4222,6 @@ gfc_expr * gfc_simplify_mod (gfc_expr *a, gfc_expr *p) { gfc_expr *result; - mpfr_t tmp; int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) @@ -4254,12 +4253,8 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_init (tmp); - mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_trunc (tmp, tmp); - mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); + mpfr_fmod (result->value.real, a->value.real, p->value.real, + GFC_RND_MODE); break; default: @@ -4274,7 +4269,6 @@ gfc_expr * gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) { gfc_expr *result; - mpfr_t tmp; int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) @@ -4308,12 +4302,17 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) } gfc_set_model_kind (kind); - mpfr_init (tmp); - mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_floor (tmp, tmp); - mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); + mpfr_fmod (result->value.real, a->value.real, p->value.real, + GFC_RND_MODE); + if (mpfr_cmp_ui (result->value.real, 0) != 0) + { + if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) + mpfr_add (result->value.real, result->value.real, p->value.real, + GFC_RND_MODE); + } + else + mpfr_copysign (result->value.real, result->value.real, + p->value.real, GFC_RND_MODE); break; default: diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 46e5f56feee..6ca4ca33014 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4882,6 +4882,9 @@ gfc_is_associate_pointer (gfc_symbol* sym) if (!sym->assoc) return false; + if (sym->ts.type == BT_CLASS) + return true; + if (!sym->assoc->variable) return false; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b54c95b4087..b24d1c323ed 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3068,6 +3068,36 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) } } + +static tree +build_array_ref (tree desc, tree offset, tree decl) +{ + tree tmp; + + /* Class array references need special treatment because the assigned + type size needs to be used to point to the element. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && TREE_CODE (desc) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) + { + tree type = gfc_get_element_type (TREE_TYPE (desc)); + tmp = TREE_OPERAND (desc, 0); + tmp = gfc_get_class_array_ref (offset, tmp); + tmp = fold_convert (build_pointer_type (type), tmp); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + } + else + { + tmp = gfc_conv_array_data (desc); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_build_array_ref (tmp, offset, decl); + } + + return tmp; +} + + + /* Build an array reference. se->expr already holds the array descriptor. This should be either a variable, indirect variable reference or component reference. For arrays which do not have a descriptor, se->expr will be @@ -3195,10 +3225,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - /* Access the calculated element. */ - tmp = gfc_conv_array_data (se->expr); - tmp = build_fold_indirect_ref (tmp); - se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->backend_decl); } @@ -6010,10 +6037,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = gfc_conv_array_data (desc); - tmp = build_fold_indirect_ref_loc (input_location, - tmp); - tmp = gfc_build_array_ref (tmp, offset, NULL); + tmp = build_array_ref (desc, offset, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index dcc2176a246..ce7114fb88d 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -697,8 +697,6 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) DECL_IGNORED_P (var_decl) = 1; if (s->sym->attr.target) TREE_ADDRESSABLE (var_decl) = 1; - /* This is a fake variable just for debugging purposes. */ - TREE_ASM_WRITTEN (var_decl) = 1; /* Fake variables are not visible from other translation units. */ TREE_PUBLIC (var_decl) = 0; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d6c090e8606..b03d393aa8e 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -457,8 +457,6 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) SET_DECL_VALUE_EXPR (decl, value); DECL_HAS_VALUE_EXPR_P (decl) = 1; GFC_DECL_CRAY_POINTEE (decl) = 1; - /* This is a fake variable just for debugging purposes. */ - TREE_ASM_WRITTEN (decl) = 1; } @@ -565,7 +563,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) /* TODO: Don't set sym->module for result or dummy variables. */ gcc_assert (current_function_decl == NULL_TREE || sym->result == sym); /* This is the declaration of a module variable. */ - if (sym->attr.access != ACCESS_PRIVATE) + if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used) TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7092bc2f153..8045b1f029b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -147,11 +147,25 @@ gfc_vtable_copy_get (tree decl) #undef VTABLE_COPY_FIELD +/* Obtain the vptr of the last class reference in an expression. */ + +tree +gfc_get_vptr_from_expr (tree expr) +{ + tree tmp = expr; + while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + tmp = TREE_OPERAND (tmp, 0); + tmp = gfc_class_vptr_get (tmp); + return tmp; +} + + /* Takes a derived type expression and returns the address of a temporary - class object of the 'declared' type. */ -static void + class object of the 'declared' type. If vptr is not NULL, this is + used for the temporary class object. */ +void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, - gfc_typespec class_ts) + gfc_typespec class_ts, tree vptr) { gfc_symbol *vtab; gfc_ss *ss; @@ -167,11 +181,19 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Set the vptr. */ ctree = gfc_class_vptr_get (var); - /* Remember the vtab corresponds to the derived type - not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + if (vptr != NULL_TREE) + { + /* Use the dynamic vptr. */ + tmp = vptr; + } + else + { + /* In this case the vtab corresponds to the derived type and the + vptr must point to it. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + } gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); @@ -3531,7 +3553,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); - gfc_conv_derived_to_class (&parmse, e, fsym->ts); + gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL); } else if (se->ss && se->ss->info->useflags) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index ab4f47fc5d3..bfbebf3269b 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1719,21 +1719,24 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag); } + /* Remainder function MOD(A, P) = A - INT(A / P) * P - MODULO(A, P) = A - FLOOR (A / P) * P */ -/* TODO: MOD(x, 0) */ + MODULO(A, P) = A - FLOOR (A / P) * P + + The obvious algorithms above are numerically instable for large + arguments, hence these intrinsics are instead implemented via calls + to the fmod family of functions. It is the responsibility of the + user to ensure that the second argument is non-zero. */ static void gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) { tree type; - tree itype; tree tmp; tree test; tree test2; tree fmod; - mpfr_t huge; - int n, ikind; + tree zero; tree args[2]; gfc_conv_intrinsic_function_args (se, expr, args, 2); @@ -1757,16 +1760,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) /* Check if we have a builtin fmod. */ fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); - /* Use it if it exists. */ - if (fmod != NULL_TREE) - { - tmp = build_addr (fmod, current_function_decl); - se->expr = build_call_array_loc (input_location, + /* The builtin should always be available. */ + gcc_assert (fmod != NULL_TREE); + + tmp = build_addr (fmod, current_function_decl); + se->expr = build_call_array_loc (input_location, TREE_TYPE (TREE_TYPE (fmod)), tmp, 2, args); - if (modulo == 0) - return; - } + if (modulo == 0) + return; type = TREE_TYPE (args[0]); @@ -1774,16 +1776,31 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) args[1] = gfc_evaluate_now (args[1], &se->pre); /* Definition: - modulo = arg - floor (arg/arg2) * arg2, so - = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, - where - test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) - thereby avoiding another division and retaining the accuracy - of the builtin function. */ - if (fmod != NULL_TREE && modulo) + modulo = arg - floor (arg/arg2) * arg2 + + In order to calculate the result accurately, we use the fmod + function as follows. + + res = fmod (arg, arg2); + if (res) + { + if ((arg < 0) xor (arg2 < 0)) + res += arg2; + } + else + res = copysign (0., arg2); + + => As two nested ternary exprs: + + res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) + : copysign (0., arg2); + + */ + + zero = gfc_build_const (type, integer_zero_node); + tmp = gfc_evaluate_now (se->expr, &se->pre); + if (!flag_signed_zeros) { - tree zero = gfc_build_const (type, integer_zero_node); - tmp = gfc_evaluate_now (se->expr, &se->pre); test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, args[0], zero); test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, @@ -1796,50 +1813,35 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) boolean_type_node, test, test2); test = gfc_evaluate_now (test, &se->pre); se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, - fold_build2_loc (input_location, PLUS_EXPR, - type, tmp, args[1]), tmp); - return; + fold_build2_loc (input_location, + PLUS_EXPR, + type, tmp, args[1]), + tmp); } - - /* If we do not have a built_in fmod, the calculation is going to - have to be done longhand. */ - tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]); - - /* Test if the value is too large to handle sensibly. */ - gfc_set_model_kind (expr->ts.kind); - mpfr_init (huge); - n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true); - ikind = expr->ts.kind; - if (n < 0) + else { - n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false); - ikind = gfc_max_integer_kind; + tree expr1, copysign, cscall; + copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, + expr->ts.kind); + test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + args[0], zero); + test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + args[1], zero); + test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, + boolean_type_node, test, test2); + expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2, + fold_build2_loc (input_location, + PLUS_EXPR, + type, tmp, args[1]), + tmp); + test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, zero); + cscall = build_call_expr_loc (input_location, copysign, 2, zero, + args[1]); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, + expr1, cscall); } - mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); - test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); - test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - tmp, test); - - mpfr_neg (huge, huge, GFC_RND_MODE); - test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); - test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp, - test); - test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, test, test2); - - itype = gfc_get_int_type (ikind); - if (modulo) - tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR); - else - tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC); - tmp = convert (type, tmp); - tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp, - args[0]); - tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]); - se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], - tmp); - mpfr_clear (huge); - break; + return; default: gcc_unreachable (); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 12a1390e2aa..323fca382c3 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1140,6 +1140,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_expr *e; tree tmp; bool class_target; + tree desc; + tree offset; + tree dim; + int n; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1191,8 +1195,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_finish_block (&se.post)); } - /* CLASS arrays just need the descriptor to be directly assigned. */ - else if (class_target && sym->attr.dimension) + /* Derived type temporaries, arising from TYPE IS, just need the + descriptor of class arrays to be assigned directly. */ + else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension) { gfc_se se; @@ -1217,7 +1222,47 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gcc_assert (!sym->attr.dimension); gfc_init_se (&se, NULL); - gfc_conv_expr (&se, e); + + /* Class associate-names come this way because they are + unconditionally associate pointers and the symbol is scalar. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + { + /* For a class array we need a descriptor for the selector. */ + gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e)); + + /* Obtain a temporary class container for the result. */ + gfc_conv_class_to_class (&se, e, sym->ts, false); + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + + /* Set the offset. */ + desc = gfc_class_data_get (se.expr); + offset = gfc_index_zero_node; + for (n = 0; n < e->rank; n++) + { + dim = gfc_rank_cst[n]; + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_stride_get (desc, dim), + gfc_conv_descriptor_lbound_get (desc, dim)); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp); + } + gfc_conv_descriptor_offset_set (&se.pre, desc, offset); + } + else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.dimension) + { + /* This is bound to be a class array element. */ + gfc_conv_expr_reference (&se, e); + /* Get the _vptr component of the class object. */ + tmp = gfc_get_vptr_from_expr (se.expr); + /* Obtain a temporary class container for the result. */ + gfc_conv_derived_to_class (&se, e, sym->ts, tmp); + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + } + else + gfc_conv_expr (&se, e); tmp = TREE_TYPE (sym->backend_decl); tmp = gfc_build_addr_expr (tmp, se.expr); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 0f2912de1af..21a94fd6f06 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1106,6 +1106,9 @@ gfc_typenode_for_spec (gfc_typespec * spec) case BT_CLASS: basetype = gfc_get_derived_type (spec->u.derived); + if (spec->type == BT_CLASS) + GFC_CLASS_TYPE_P (basetype) = 1; + /* If we're dealing with either C_PTR or C_FUNPTR, we modified the type and kind to fit a (void *) and the basetype returned was a ptr_type_node. We need to pass up this new information to the diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 08a67325274..3b77281568a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,8 +348,10 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree); +void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree); void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool); /* Initialize an init/cleanup block. */ @@ -827,6 +829,8 @@ struct GTY((variable_size)) lang_decl { #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node) /* Fortran POINTER type. */ #define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node) +/* Fortran CLASS type. */ +#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node) /* The GFC_TYPE_ARRAY_* members are present in both descriptor and descriptorless array types. */ #define GFC_TYPE_ARRAY_LBOUND(node, dim) \ |