Mercurial > hg > CbC > CbC_gcc
diff gcc/fortran/expr.c @ 145:1830386684a0
gcc-9.2.0
| author | anatofuz |
|---|---|
| date | Thu, 13 Feb 2020 11:34:05 +0900 |
| parents | 84e7813d76e9 |
| children |
line wrap: on
line diff
--- a/gcc/fortran/expr.c Thu Oct 25 07:37:49 2018 +0900 +++ b/gcc/fortran/expr.c Thu Feb 13 11:34:05 2020 +0900 @@ -1,5 +1,5 @@ /* Routines for manipulation of expression nodes. - Copyright (C) 2000-2018 Free Software Foundation, Inc. + Copyright (C) 2000-2020 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -342,6 +342,13 @@ case BT_ASSUMED: break; /* Already done. */ + case BT_BOZ: + q->boz.len = p->boz.len; + q->boz.rdx = p->boz.rdx; + q->boz.str = XCNEWVEC (char, q->boz.len + 1); + strncpy (q->boz.str, p->boz.str, p->boz.len); + break; + case BT_PROCEDURE: case BT_VOID: /* Should never be reached. */ @@ -390,6 +397,9 @@ case EXPR_VARIABLE: case EXPR_NULL: break; + + case EXPR_UNKNOWN: + gcc_unreachable (); } q->shape = gfc_copy_shape (p->shape, p->rank); @@ -599,6 +609,7 @@ break; case REF_COMPONENT: + case REF_INQUIRY: break; } @@ -756,6 +767,10 @@ dest->u.c = src->u.c; break; + case REF_INQUIRY: + dest->u.i = src->u.i; + break; + case REF_SUBSTRING: dest->u.ss = src->u.ss; dest->u.ss.start = gfc_copy_expr (src->u.ss.start); @@ -1053,6 +1068,27 @@ } +/* Is true if the expression or symbol is a passed CFI descriptor. */ +bool +is_CFI_desc (gfc_symbol *sym, gfc_expr *e) +{ + if (sym == NULL + && e && e->expr_type == EXPR_VARIABLE) + sym = e->symtree->n.sym; + + if (sym && sym->attr.dummy + && sym->ns->proc_name->attr.is_bind_c + && sym->attr.dimension + && (sym->attr.pointer + || sym->attr.allocatable + || sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)) + return true; + +return false; +} + + /* Is true if an array reference is followed by a component or substring reference. */ bool @@ -1060,22 +1096,29 @@ { gfc_ref * ref; bool seen_array; + gfc_symbol *sym; if (e->expr_type != EXPR_VARIABLE) return false; - if (e->symtree->n.sym->attr.subref_array_pointer) - return true; - - if (e->symtree->n.sym->ts.type == BT_CLASS - && e->symtree->n.sym->attr.dummy - && CLASS_DATA (e->symtree->n.sym)->attr.dimension - && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer) + sym = e->symtree->n.sym; + + if (sym->attr.subref_array_pointer) return true; seen_array = false; + for (ref = e->ref; ref; ref = ref->next) { + /* If we haven't seen the array reference and this is an intrinsic, + what follows cannot be a subreference array, unless there is a + substring reference. */ + if (!seen_array && ref->type == REF_COMPONENT + && ref->u.c.component->ts.type != BT_CHARACTER + && ref->u.c.component->ts.type != BT_CLASS + && !gfc_bt_struct (ref->u.c.component->ts.type)) + return false; + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) seen_array = true; @@ -1084,6 +1127,13 @@ && ref->type != REF_ARRAY) return seen_array; } + + if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && CLASS_DATA (sym)->attr.dimension + && CLASS_DATA (sym)->attr.class_pointer) + return true; + return false; } @@ -1628,7 +1678,7 @@ { gfc_error ("The number of elements in the array constructor " "at %L requires an increase of the allowed %d " - "upper limit. See -fmax-array-constructor " + "upper limit. See %<-fmax-array-constructor%> " "option", &expr->where, flag_max_array_constructor); return false; } @@ -1691,6 +1741,118 @@ } +/* Pull an inquiry result out of an expression. */ + +static bool +find_inquiry_ref (gfc_expr *p, gfc_expr **newp) +{ + gfc_ref *ref; + gfc_ref *inquiry = NULL; + gfc_expr *tmp; + + tmp = gfc_copy_expr (p); + + if (tmp->ref && tmp->ref->type == REF_INQUIRY) + { + inquiry = tmp->ref; + tmp->ref = NULL; + } + else + { + for (ref = tmp->ref; ref; ref = ref->next) + if (ref->next && ref->next->type == REF_INQUIRY) + { + inquiry = ref->next; + ref->next = NULL; + } + } + + if (!inquiry) + { + gfc_free_expr (tmp); + return false; + } + + gfc_resolve_expr (tmp); + + /* In principle there can be more than one inquiry reference. */ + for (; inquiry; inquiry = inquiry->next) + { + switch (inquiry->u.i) + { + case INQUIRY_LEN: + if (tmp->ts.type != BT_CHARACTER) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + goto cleanup; + + if (tmp->ts.u.cl->length + && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) + *newp = gfc_copy_expr (tmp->ts.u.cl->length); + else if (tmp->expr_type == EXPR_CONSTANT) + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp->value.character.length); + else + goto cleanup; + + break; + + case INQUIRY_KIND: + if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) + goto cleanup; + + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp->ts.kind); + break; + + case INQUIRY_RE: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_realref (tmp->value.complex), GFC_RND_MODE); + break; + + case INQUIRY_IM: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_imagref (tmp->value.complex), GFC_RND_MODE); + break; + } + tmp = gfc_copy_expr (*newp); + } + + if (!(*newp)) + goto cleanup; + else if ((*newp)->expr_type != EXPR_CONSTANT) + { + gfc_free_expr (*newp); + goto cleanup; + } + + gfc_free_expr (tmp); + return true; + +cleanup: + gfc_free_expr (tmp); + return false; +} + + /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ @@ -1699,7 +1861,7 @@ simplify_const_ref (gfc_expr *p) { gfc_constructor *cons, *c; - gfc_expr *newp; + gfc_expr *newp = NULL; gfc_ref *last_ref; while (p->ref) @@ -1775,8 +1937,14 @@ string_len = 0; if (!p->ts.u.cl) - p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, - NULL); + { + if (p->symtree) + p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, + NULL); + else + p->ts.u.cl = gfc_new_charlen (gfc_current_ns, + NULL); + } else gfc_free_expr (p->ts.u.cl->length); @@ -1800,8 +1968,17 @@ remove_subobject_ref (p, cons); break; + case REF_INQUIRY: + if (!find_inquiry_ref (p, &newp)) + return false; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + case REF_SUBSTRING: - if (!find_substring_ref (p, &newp)) + if (!find_substring_ref (p, &newp)) return false; gfc_replace_expr (p, newp); @@ -1818,9 +1995,10 @@ /* Simplify a chain of references. */ static bool -simplify_ref_chain (gfc_ref *ref, int type) +simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) { int n; + gfc_expr *newp; for (; ref; ref = ref->next) { @@ -1845,6 +2023,15 @@ return false; break; + case REF_INQUIRY: + if (!find_inquiry_ref (*p, &newp)) + return false; + + gfc_replace_expr (*p, newp); + gfc_free_ref_list ((*p)->ref); + (*p)->ref = NULL; + return true; + default: break; } @@ -1861,6 +2048,15 @@ gfc_expr *e; bool t; + /* Set rank and check array ref; as resolve_variable calls + gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */ + if (!gfc_resolve_ref (p)) + { + gfc_error_check (); + return false; + } + gfc_expression_rank (p); + if (gfc_is_size_zero_array (p)) { if (p->expr_type == EXPR_ARRAY) @@ -1883,10 +2079,14 @@ e->rank = p->rank; + if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl); + /* Do not copy subobject refs for constant. */ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) e->ref = gfc_copy_ref (p->ref); t = gfc_simplify_expr (e, type); + e->where = p->where; /* Only use the simplification if it eliminated all subobject references. */ if (t && !e->ref) @@ -1918,7 +2118,7 @@ 1 Simplifying array constructors -- will substitute iterator values. Returns false on error, true otherwise. - NOTE: Will return true even if the expression can not be simplified. */ + NOTE: Will return true even if the expression cannot be simplified. */ bool gfc_simplify_expr (gfc_expr *p, int type) @@ -1933,6 +2133,9 @@ switch (p->expr_type) { case EXPR_CONSTANT: + if (p->ref && p->ref->type == REF_INQUIRY) + simplify_ref_chain (p->ref, type, &p); + break; case EXPR_NULL: break; @@ -1969,7 +2172,7 @@ break; case EXPR_SUBSTRING: - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; if (gfc_is_constant_expr (p)) @@ -2031,16 +2234,21 @@ } /* Simplify subcomponent references. */ - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; break; case EXPR_STRUCTURE: case EXPR_ARRAY: - if (!simplify_ref_chain (p->ref, type)) + if (!simplify_ref_chain (p->ref, type, &p)) return false; + /* If the following conditions hold, we found something like kind type + inquiry of the form a(2)%kind while simplify the ref chain. */ + if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape) + return true; + if (!simplify_constructor (p->value.constructor, type)) return false; @@ -2056,6 +2264,9 @@ case EXPR_COMPCALL: case EXPR_PPC: break; + + case EXPR_UNKNOWN: + gcc_unreachable (); } return true; @@ -2380,7 +2591,8 @@ static bool check_restricted (gfc_expr *); /* F95, 7.1.6.1, Initialization expressions, (7) - F2003, 7.1.7 Initialization expression, (8) */ + F2003, 7.1.7 Initialization expression, (8) + F2008, 7.1.12 Constant expression, (4) */ static match check_inquiry (gfc_expr *e, int not_restricted) @@ -2404,8 +2616,19 @@ "new_line", NULL }; + /* std=f2008+ or -std=gnu */ + static const char *const inquiry_func_gnu[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + "new_line", "storage_size", NULL + }; + int i = 0; gfc_actual_arglist *ap; + gfc_symbol *sym; + gfc_symbol *asym; if (!e->value.function.isym || !e->value.function.isym->inquiry) @@ -2415,23 +2638,28 @@ if (e->symtree == NULL) return MATCH_NO; - if (e->symtree->n.sym->from_intmod) + sym = e->symtree->n.sym; + + if (sym->from_intmod) { - if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV - && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS - && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) + if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS + && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) return MATCH_NO; - if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING - && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) + if (sym->from_intmod == INTMOD_ISO_C_BINDING + && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) return MATCH_NO; } else { - name = e->symtree->n.sym->name; - - functions = (gfc_option.warn_std & GFC_STD_F2003) - ? inquiry_func_f2003 : inquiry_func_f95; + name = sym->name; + + functions = inquiry_func_gnu; + if (gfc_option.warn_std & GFC_STD_F2003) + functions = inquiry_func_f2003; + if (gfc_option.warn_std & GFC_STD_F95) + functions = inquiry_func_f95; for (i = 0; functions[i]; i++) if (strcmp (functions[i], name) == 0) @@ -2450,41 +2678,48 @@ if (!ap->expr) continue; + asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL; + if (ap->expr->ts.type == BT_UNKNOWN) { - if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)) + if (asym && asym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (asym, 0, gfc_current_ns)) return MATCH_NO; - ap->expr->ts = ap->expr->symtree->n.sym->ts; + ap->expr->ts = asym->ts; + } + + if (asym && asym->assoc && asym->assoc->target + && asym->assoc->target->expr_type == EXPR_CONSTANT) + { + gfc_free_expr (ap->expr); + ap->expr = gfc_copy_expr (asym->assoc->target); } - /* Assumed character length will not reduce to a constant expression - with LEN, as required by the standard. */ - if (i == 5 && not_restricted && ap->expr->symtree - && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER - && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL - || ap->expr->symtree->n.sym->ts.deferred)) - { - gfc_error ("Assumed or deferred character length variable %qs " - "in constant expression at %L", - ap->expr->symtree->n.sym->name, - &ap->expr->where); - return MATCH_ERROR; - } - else if (not_restricted && !gfc_check_init_expr (ap->expr)) + /* Assumed character length will not reduce to a constant expression + with LEN, as required by the standard. */ + if (i == 5 && not_restricted && asym + && asym->ts.type == BT_CHARACTER + && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL) + || asym->ts.deferred)) + { + gfc_error ("Assumed or deferred character length variable %qs " + "in constant expression at %L", + asym->name, &ap->expr->where); return MATCH_ERROR; - - if (not_restricted == 0 - && ap->expr->expr_type != EXPR_VARIABLE - && !check_restricted (ap->expr)) - return MATCH_ERROR; - - if (not_restricted == 0 - && ap->expr->expr_type == EXPR_VARIABLE - && ap->expr->symtree->n.sym->attr.dummy - && ap->expr->symtree->n.sym->attr.optional) - return MATCH_NO; + } + else if (not_restricted && !gfc_check_init_expr (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type != EXPR_VARIABLE + && !check_restricted (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type == EXPR_VARIABLE + && asym->attr.dummy && asym->attr.optional) + return MATCH_NO; } return MATCH_YES; @@ -2509,6 +2744,13 @@ "trim", "unpack", NULL }; + static const char * const trans_func_f2008[] = { + "all", "any", "count", "dot_product", "matmul", "null", "pack", + "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", + "selected_real_kind", "spread", "sum", "transfer", "transpose", + "trim", "unpack", "findloc", NULL + }; + int i; const char *name; const char *const *functions; @@ -2519,8 +2761,12 @@ name = e->symtree->n.sym->name; - functions = (gfc_option.allow_std & GFC_STD_F2003) - ? trans_func_f2003 : trans_func_f95; + if (gfc_option.allow_std & GFC_STD_F2008) + functions = trans_func_f2008; + else if (gfc_option.allow_std & GFC_STD_F2003) + functions = trans_func_f2003; + else + functions = trans_func_f95; /* NULL() is dealt with below. */ if (strcmp ("null", name) == 0) @@ -2723,9 +2969,16 @@ break; case AS_DEFERRED: - gfc_error ("Deferred array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); + if (!e->symtree->n.sym->attr.allocatable + && !e->symtree->n.sym->attr.pointer + && e->symtree->n.sym->attr.dummy) + gfc_error ("Assumed-shape array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + else + gfc_error ("Deferred array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); break; case AS_EXPLICIT: @@ -2814,7 +3067,7 @@ t = gfc_check_init_expr (expr); gfc_init_expr_flag = false; - if (!t) + if (!t || !expr) return false; if (expr->expr_type == EXPR_ARRAY) @@ -2915,6 +3168,7 @@ || !strcmp (f->name, "ieee_support_halting") || !strcmp (f->name, "ieee_support_datatype") || !strcmp (f->name, "ieee_support_denormal") + || !strcmp (f->name, "ieee_support_subnormal") || !strcmp (f->name, "ieee_support_divide") || !strcmp (f->name, "ieee_support_inf") || !strcmp (f->name, "ieee_support_io") @@ -3091,12 +3345,14 @@ restricted expression in an elemental procedure, it will have already been simplified away once we get here. Therefore we don't need to jump through hoops to distinguish valid from - invalid cases. */ - if (sym->attr.dummy && sym->ns == gfc_current_ns + invalid cases. Allowed in F2008 and F2018. */ + if (gfc_notification_std (GFC_STD_F2008) + && sym->attr.dummy && sym->ns == gfc_current_ns && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) { - gfc_error ("Dummy argument %qs not allowed in expression at %L", - sym->name, &e->where); + gfc_error_now ("Dummy argument %qs not " + "allowed in expression at %L", + sym->name, &e->where); break; } @@ -3239,8 +3495,10 @@ return true; va_start (argp, optype_msgid); - vsnprintf (buffer, 240, optype_msgid, argp); + d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); va_end (argp); + if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ + gfc_internal_error ("optype_msgid overflow: %d", d); if (op1->rank != op2->rank) { @@ -3295,14 +3553,22 @@ sym = lvalue->symtree->n.sym; - /* See if this is the component or subcomponent of a pointer. */ + /* See if this is the component or subcomponent of a pointer and guard + against assignment to LEN or KIND part-refs. */ has_pointer = sym->attr.pointer; for (ref = lvalue->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) - { - has_pointer = 1; - break; - } + { + if (!has_pointer && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pointer) + has_pointer = 1; + else if (ref->type == REF_INQUIRY + && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) + { + gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " + "allowed", &lvalue->where); + return false; + } + } /* 12.5.2.2, Note 12.26: The result variable is very similar to any other variable local to a function subprogram. Its existence begins when @@ -3358,6 +3624,18 @@ return false; } } + else + { + /* Reject assigning to an external symbol. For initializers, this + was already done before, in resolve_fl_procedure. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external + && sym->attr.proc != PROC_MODULE && !rvalue->error) + { + gfc_error ("Illegal assignment to external procedure at %L", + &lvalue->where); + return false; + } + } if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) { @@ -3398,45 +3676,44 @@ && !gfc_check_conformance (lvalue, rvalue, "array assignment")) return false; - if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER - && lvalue->symtree->n.sym->attr.data - && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " - "initialize non-integer variable %qs", - &rvalue->where, lvalue->symtree->n.sym->name)) - return false; - else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data - && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", - &rvalue->where)) - return false; - /* Handle the case of a BOZ literal on the RHS. */ - if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) + if (rvalue->ts.type == BT_BOZ) { - int rc; - if (warn_surprising) - gfc_warning (OPT_Wsurprising, - "BOZ literal at %L is bitwise transferred " - "non-integer symbol %qs", &rvalue->where, - lvalue->symtree->n.sym->name); - if (!gfc_convert_boz (rvalue, &lvalue->ts)) - return false; - if ((rc = gfc_range_check (rvalue)) != ARITH_OK) + if (lvalue->symtree->n.sym->attr.data) { - if (rc == ARITH_UNDERFLOW) - gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L" - ". This check can be disabled with the option " - "%<-fno-range-check%>", &rvalue->where); - else if (rc == ARITH_OVERFLOW) - gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L" - ". This check can be disabled with the option " - "%<-fno-range-check%>", &rvalue->where); - else if (rc == ARITH_NAN) - gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" - ". This check can be disabled with the option " - "%<-fno-range-check%>", &rvalue->where); - return false; + if (lvalue->ts.type == BT_INTEGER + && gfc_boz2int (rvalue, lvalue->ts.kind)) + return true; + + if (lvalue->ts.type == BT_REAL + && gfc_boz2real (rvalue, lvalue->ts.kind)) + { + if (gfc_invalid_boz ("BOZ literal constant near %L cannot " + "be assigned to a REAL variable", + &rvalue->where)) + return false; + return true; + } } + + if (!lvalue->symtree->n.sym->attr.data + && gfc_invalid_boz ("BOZ literal constant at %L is neither a " + "data-stmt-constant nor an actual argument to " + "INT, REAL, DBLE, or CMPLX intrinsic function", + &rvalue->where)) + return false; + + if (lvalue->ts.type == BT_INTEGER + && gfc_boz2int (rvalue, lvalue->ts.kind)) + return true; + + if (lvalue->ts.type == BT_REAL + && gfc_boz2real (rvalue, lvalue->ts.kind)) + return true; + + gfc_error ("BOZ literal constant near %L cannot be assigned to a " + "%qs variable", &rvalue->where, gfc_typename (lvalue)); + return false; } if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) @@ -3461,13 +3738,19 @@ || rvalue->ts.type == BT_HOLLERITH) return true; + if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) + || lvalue->ts.type == BT_LOGICAL) + && rvalue->ts.type == BT_CHARACTER + && rvalue->ts.kind == gfc_default_character_kind) + return true; + if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) return true; where = lvalue->where.lb ? &lvalue->where : &rvalue->where; gfc_error ("Incompatible types in DATA statement at %L; attempted " "conversion of %s to %s", where, - gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); + gfc_typename (rvalue), gfc_typename (lvalue)); return false; } @@ -3494,12 +3777,14 @@ NULLIFY statement. */ bool -gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) +gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, + bool suppress_type_test, bool is_init_expr) { symbol_attribute attr, lhs_attr; gfc_ref *ref; bool is_pure, is_implicit_pure, rank_remap; int proc_pointer; + bool same_rank; lhs_attr = gfc_expr_attr (lvalue); if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) @@ -3521,6 +3806,7 @@ proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; rank_remap = false; + same_rank = lvalue->rank == rvalue->rank; for (ref = lvalue->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT) @@ -3545,34 +3831,66 @@ lvalue->symtree->n.sym->name, &lvalue->where)) return false; - /* When bounds are given, all lbounds are necessary and either all - or none of the upper bounds; no strides are allowed. If the - upper bounds are present, we may do rank remapping. */ + /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): + * + * (C1017) If bounds-spec-list is specified, the number of + * bounds-specs shall equal the rank of data-pointer-object. + * + * If bounds-spec-list appears, it specifies the lower bounds. + * + * (C1018) If bounds-remapping-list is specified, the number of + * bounds-remappings shall equal the rank of data-pointer-object. + * + * If bounds-remapping-list appears, it specifies the upper and + * lower bounds of each dimension of the pointer; the pointer target + * shall be simply contiguous or of rank one. + * + * (C1019) If bounds-remapping-list is not specified, the ranks of + * data-pointer-object and data-target shall be the same. + * + * Thus when bounds are given, all lbounds are necessary and either + * all or none of the upper bounds; no strides are allowed. If the + * upper bounds are present, we may do rank remapping. */ for (dim = 0; dim < ref->u.ar.dimen; ++dim) { - if (!ref->u.ar.start[dim] - || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - { - gfc_error ("Lower bound has to be present at %L", - &lvalue->where); - return false; - } if (ref->u.ar.stride[dim]) { gfc_error ("Stride must not be present at %L", &lvalue->where); return false; } + if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) + { + gfc_error ("Rank remapping requires a " + "list of %<lower-bound : upper-bound%> " + "specifications at %L", &lvalue->where); + return false; + } + if (!ref->u.ar.start[dim] + || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + { + gfc_error ("Expected list of %<lower-bound :%> or " + "list of %<lower-bound : upper-bound%> " + "specifications at %L", &lvalue->where); + return false; + } if (dim == 0) rank_remap = (ref->u.ar.end[dim] != NULL); else { - if ((rank_remap && !ref->u.ar.end[dim]) - || (!rank_remap && ref->u.ar.end[dim])) + if ((rank_remap && !ref->u.ar.end[dim])) { - gfc_error ("Either all or none of the upper bounds" - " must be specified at %L", &lvalue->where); + gfc_error ("Rank remapping requires a " + "list of %<lower-bound : upper-bound%> " + "specifications at %L", &lvalue->where); + return false; + } + if (!rank_remap && ref->u.ar.end[dim]) + { + gfc_error ("Expected list of %<lower-bound :%> or " + "list of %<lower-bound : upper-bound%> " + "specifications at %L", &lvalue->where); return false; } } @@ -3622,6 +3940,7 @@ &rvalue->where); return false; } + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) { /* Check for intrinsics. */ @@ -3818,6 +4137,16 @@ return true; } + else + { + /* A non-proc pointer cannot point to a constant. */ + if (rvalue->expr_type == EXPR_CONSTANT) + { + gfc_error_now ("Pointer assignment target cannot be a constant at %L", + &rvalue->where); + return false; + } + } if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { @@ -3831,11 +4160,10 @@ "polymorphic, or of a type with the BIND or SEQUENCE " "attribute, to be compatible with an unlimited " "polymorphic target", &lvalue->where); - else + else if (!suppress_type_test) gfc_error ("Different types in pointer assignment at %L; " "attempted assignment of %s to %s", &lvalue->where, - gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts)); + gfc_typename (rvalue), gfc_typename (lvalue)); return false; } @@ -3925,11 +4253,35 @@ return false; } - if (!attr.target && !attr.pointer) + if (is_init_expr) { - gfc_error ("Pointer assignment target is neither TARGET " - "nor POINTER at %L", &rvalue->where); - return false; + gfc_symbol *sym; + bool target; + + gcc_assert (rvalue->symtree); + sym = rvalue->symtree->n.sym; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + target = CLASS_DATA (sym)->attr.target; + else + target = sym->attr.target; + + if (!target && !proc_pointer) + { + gfc_error ("Pointer assignment target in initialization expression " + "does not have the TARGET attribute at %L", + &rvalue->where); + return false; + } + } + else + { + if (!attr.target && !attr.pointer) + { + gfc_error ("Pointer assignment target is neither TARGET " + "nor POINTER at %L", &rvalue->where); + return false; + } } if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) @@ -4063,7 +4415,7 @@ } if (pointer || proc_pointer) - r = gfc_check_pointer_assign (&lvalue, rvalue); + r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); else { /* If a conversion function, e.g., __convert_i8_i4, was inserted @@ -4083,7 +4435,7 @@ if (!r) return r; - if (pointer && rvalue->expr_type != EXPR_NULL) + if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) { /* F08:C461. Additional checks for pointer initialization. */ symbol_attribute attr; @@ -4127,6 +4479,20 @@ "may not be a procedure pointer", &rvalue->where); return false; } + if (attr.proc == PROC_INTERNAL) + { + gfc_error ("Internal procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + if (attr.dummy) + { + gfc_error ("Dummy procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } } return true; @@ -4312,12 +4678,10 @@ { if (ts->type == BT_CHARACTER && !attr->pointer && init && ts->u.cl - && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER) { - gcc_assert (ts->u.cl && ts->u.cl->length); - gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT); - gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER); - HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (init->expr_type == EXPR_CONSTANT) @@ -4490,7 +4854,6 @@ comp_pointer (gfc_component *comp) { return comp->attr.pointer - || comp->attr.pointer || comp->attr.proc_pointer || comp->attr.class_pointer || class_pointer (comp); @@ -4780,6 +5143,7 @@ continue; case REF_SUBSTRING: + case REF_INQUIRY: continue; case REF_ARRAY: @@ -4932,6 +5296,9 @@ } break; + case REF_INQUIRY: + return true; + default: gcc_unreachable (); } @@ -5286,6 +5653,7 @@ break; case REF_SUBSTRING: + case REF_INQUIRY: break; } @@ -5393,6 +5761,9 @@ gfc_ref *ref, *part_ref = NULL; gfc_symbol *sym; + if (expr->expr_type == EXPR_ARRAY) + return true; + if (expr->expr_type == EXPR_FUNCTION) { if (expr->value.function.esym) @@ -5506,6 +5877,75 @@ return true; } +/* Return true if the expression is guaranteed to be non-contiguous, + false if we cannot prove anything. It is probably best to call + this after gfc_is_simply_contiguous. If neither of them returns + true, we cannot say (at compile-time). */ + +bool +gfc_is_not_contiguous (gfc_expr *array) +{ + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref; + bool previous_incomplete; + + for (ref = array->ref; ref; ref = ref->next) + { + /* Array-ref shall be last ref. */ + + if (ar) + return true; + + if (ref->type == REF_ARRAY) + ar = &ref->u.ar; + } + + if (ar == NULL || ar->type != AR_SECTION) + return false; + + previous_incomplete = false; + + /* Check if we can prove that the array is not contiguous. */ + + for (i = 0; i < ar->dimen; i++) + { + mpz_t arr_size, ref_size; + + if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) + { + if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size)) + { + /* a(2:4,2:) is known to be non-contiguous, but + a(2:4,i:i) can be contiguous. */ + if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) + { + mpz_clear (arr_size); + mpz_clear (ref_size); + return true; + } + else if (mpz_cmp (arr_size, ref_size) != 0) + previous_incomplete = true; + + mpz_clear (arr_size); + } + + /* Check for a(::2), i.e. where the stride is not unity. + This is only done if there is more than one element in + the reference along this dimension. */ + + if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION + && ar->dimen_type[i] == DIMEN_RANGE + && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT + && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) + return true; + + mpz_clear (ref_size); + } + } + /* We didn't find anything definitive. */ + return false; +} /* Build call to an intrinsic procedure. The number of arguments has to be passed (rather than ending the list with a NULL value) because we may @@ -5697,7 +6137,12 @@ check_intentin = false; } } - if (check_intentin && sym->attr.intent == INTENT_IN) + + if (check_intentin + && (sym->attr.intent == INTENT_IN + || (sym->attr.select_type_temporary && sym->assoc + && sym->assoc->target && sym->assoc->target->symtree + && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) { if (pointer && is_pointer) { @@ -5709,10 +6154,12 @@ } if (!pointer && !is_pointer && !sym->attr.pointer) { + const char *name = sym->attr.select_type_temporary + ? sym->assoc->target->symtree->name : sym->name; if (context) gfc_error ("Dummy argument %qs with INTENT(IN) in variable" " definition context (%s) at %L", - sym->name, context, &e->where); + name, context, &e->where); return false; } } @@ -5723,7 +6170,7 @@ if (pointer && is_pointer) { if (context) - gfc_error ("Variable %qs is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and cannot appear in a" " pointer association context (%s) at %L", sym->name, context, &e->where); return false; @@ -5731,7 +6178,7 @@ if (!pointer && !is_pointer) { if (context) - gfc_error ("Variable %qs is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and cannot appear in a" " variable definition context (%s) at %L", sym->name, context, &e->where); return false; @@ -5743,7 +6190,7 @@ if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) { if (context) - gfc_error ("Variable %qs can not appear in a variable definition" + gfc_error ("Variable %qs cannot appear in a variable definition" " context (%s) at %L in PURE procedure", sym->name, context, &e->where); return false; @@ -5768,7 +6215,7 @@ } } /* Check variable definition context for associate-names. */ - if (!pointer && sym->assoc) + if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) { const char* name; gfc_association_list* assoc; @@ -5802,12 +6249,14 @@ if (context) { if (assoc->target->expr_type == EXPR_VARIABLE) - gfc_error ("%qs at %L associated to vector-indexed target can" - " not be used in a variable definition context (%s)", + gfc_error ("%qs at %L associated to vector-indexed target" + " cannot be used in a variable definition" + " context (%s)", name, &e->where, context); else - gfc_error ("%qs at %L associated to expression can" - " not be used in a variable definition context (%s)", + gfc_error ("%qs at %L associated to expression" + " cannot be used in a variable definition" + " context (%s)", name, &e->where, context); } return false; @@ -5817,9 +6266,9 @@ if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) { if (context) - gfc_error ("Associate-name %qs can not appear in a variable" + gfc_error ("Associate-name %qs cannot appear in a variable" " definition context (%s) at %L because its target" - " at %L can not, either", + " at %L cannot, either", name, context, &e->where, &assoc->target->where); return false;